diff --git a/README.md b/README.md index 0ed952ca..873ef788 100644 --- a/README.md +++ b/README.md @@ -262,9 +262,9 @@ driver at all — it goes `llc` + `ld -shared` + `dlopen`, which is what makes is a confusing shape of failure to meet without warning. Variables beginning `FLAN_DEV_` other than `FLAN_DEV_LEAKS`, plus -`FLAN_AGENT_SOCKET` and `FLAN_COMPILER_STAMP`, are internal: `flan dev` sets -them across its own `exec` to hand the merged binary what it needs. Setting -them by hand is not supported. +`FLAN_AGENT_SOCKET`, `FLAN_AGENT_OWNER` and `FLAN_COMPILER_STAMP`, are +internal: `flan dev` sets them across its own `exec` to hand the merged binary +what it needs. Setting them by hand is not supported. ## Checking it diff --git a/TODO.org b/TODO.org index d2c3d726..45c6a7bc 100644 --- a/TODO.org +++ b/TODO.org @@ -296,6 +296,14 @@ keyword resolves against the expected type and against nothing else, so two enum could always share a member spelling. What the prefix buys is the call site read on its own. +** WAIT ML-style patterns +Held 2026-09-25 as a future direction, like the JS backend: nested destructuring, +guards, or-patterns, literals at any depth, exhaustiveness over the nesting. + +** NEXT match over numbers and strings +Decided 2026-09-25: a match arm's pattern can be an integer, a float, a char or a +string literal, compared as =(= t lit)=; a match over such a type needs a =_= arm. + ** DONE match over enums CLOSED: [2026-09-25] =Ast.Pkw= is the keyword pattern; =Check.check_match= resolves it against the @@ -630,12 +638,6 @@ generic binding — saying =$= marks a type variable and naming the bare spelling. A =defn= parameter was already refused, as a type in a name slot. -** NEXT A container parameter the function grows is warned at -Decided 2026-09-25: Odin's behaviour stays — a Vec or Map passed by value is a -copy of its header, so growth inside the callee does not reach the caller. A -parameter the function grows (push, put, reserve, anything that can reallocate) -gets a warning at the parameter suggesting (Ptr ...). - ** CANCELLED not= as a spelling of != CLOSED: [2026-09-25] One spelling for one operation; != stays, and not= is refused with a suggestion @@ -643,6 +645,10 @@ of !=. * Checker +** WAIT A _ body that returns an fn literal +Refused today; allowing it when the literal writes its parameter types is the +proposal. Postponed 2026-09-25 while .fln takes priority. + ** DONE The ownership flow analysis is repealed CLOSED: [2026-09-18] Static use-after-move and double-free checking is gone; types, allocators and the @@ -680,14 +686,6 @@ A machine-type target needs =numeric?=; an enum target needs =integer?=; by what it claims, not by the set it happens to denote this week — which is why =ordered?= is refused even though every type it admits today converts. -** NEXT There is now no generic enum to integer conversion -Decided 2026-09-25: build =enum?= as described. -Recorded as a loss. The one spelling that worked did so by not asking about the -operand at all, so removing it was still right. =enum?= is the eventual answer — -it would entail =ordered?= and =equal?= and not =numeric?=, so the cast rule -becomes a disjunction and the refusal has to name whichever the reader meant. Each -part of that is a decision and the author has not been asked. - ** DONE The Ptr and union arms of the fill boundary are relaxable CLOSED: [2026-09-25] A =Ptr= may be byte-filled, and an untagged union is filled over its whole @@ -750,15 +748,10 @@ depth it gave up at. The bare depth number is a backstop that also prints the chain. Before any of it, the compiler hung rather than failed, which wedges =C-c C-c= with nothing to show. -** NEXT Generic types -Decided 2026-09-25: the freeze is lifted for this; build both type and length parameters. -=(defstruct Pair [a $t b $t])= cannot be spelled, and neither can a length -parameter. =Types.Named= is a bare string with no room for parameters; giving it -some changes the type, the layout calculator, both backends, the renderer and the -DWARF path. Same price for one as for both. Decided and unblocked, deliberately -not started — it is a language feature under a freeze, and it was stopped once -already for that reason. The motivating case is Odin's =Small_Array=: a -fixed-capacity array with a count and no allocation. +** DONE Generic types +CLOSED: [2026-09-25] +A struct's parameters are its fields' $-names in first-written order, a length by position; there is no +explicit parameter vector. Each application is an ordinary struct under a key, so no backend sees a parameter. ** WAIT A value predicate over a length parameter Decided 2026-09-25: waits until a program wants one. @@ -767,12 +760,6 @@ clause here admits nothing but type predicates. Whether it should take value predicates over a length parameter deserves answering deliberately rather than falling out of the implementation. -** TODO "In instantiation of" notes -A refusal inside a copy points at the generic's source with no note naming the -call site that asked for that type. The data is there — =instantiation_origin= -exists and the session already uses it — and wiring it into every failure under an -instantiation is a lane of its own. - ** DONE A program is one compilation, so a generic's body is always visible CLOSED: [2026-09-25] Odin's and Zig's model: packages are never compiled separately. The cost is build @@ -856,34 +843,12 @@ CLOSED: [2026-09-20] typed conditions stay strict =bool=. =and= and =or= hand back the operand that decided them, Clojure's rule, through a desugaring that evaluates each test once. -** NEXT A bool arm and a dyn arm joining as dyn -Decided 2026-09-25: they join as =dyn=, the =bool= boxed — Clojure's rule, so =(or false (box "s"))= answers ="s"=. -With both arms of a desugared =and=/=or= holding real values, a non-bool =dyn= on -the losing side meets the strict =bool= boundary and traps — -=(or false (box "s"))= is the case. Whether a =bool= arm and a =dyn= arm should -join as =dyn= is the author's call and is not settled. - -** NEXT A truthiness failure re-runs the whole failing subtree -Decided 2026-09-25: fix it without changing any message — the retry reuses what the first pass settled for each subtree (memoised by node), so nested =not= is linear. Test with a deep nest that must fail fast and with the existing message tests unchanged. -The retry exists to keep a refused literal's message unchanged and re-runs the -subtree rather than the leaf, which is exponential in nested =not= depth on a -program that does not type-check. Moot for anything that compiles; only the -daemon's half-typed recompiles could feel it. A cheaper retry was tried and -shelved because it changes which literal gets the nicer message. - ** DONE and's last operand gets a misdirected caret CLOSED: [2026-09-25] Already fixed by 3672da2, which blames the arm that is not a compiler temp; the caret is on the last operand and =test/test_flan.ml= asserts its column. Rules out relabelling the else arm, a bool sentinel, and inverting the condition. -** NEXT Signature pairing's cold-rebuild edge -Decided 2026-09-25: the type takes precedence, as today. The warning is at the parameter site: where a name in a parameter vector is read as a program-declared type but could also have been read as a parameter name, the parameter vector gets a warning naming the type and where it is declared. -Whether a parameter vector reads as one annotated parameter or two dyn ones -depends on what type names exist, so adding a type can silently re-pair an -existing signature between compiles. A changed-pairing warning was proposed and -not queued. - ** DONE A typed container crosses into dyn as a view, and only from permanent storage CLOSED: [2026-09-20] The descriptor is pointer, length and element type — a slice plus the piece a @@ -905,6 +870,7 @@ semantics; the refined version needs liveness across control flow, which is the flow tracking that was repealed. ** NEXT Catching a use-after-release statically +Decided 2026-09-25 (91): build (A) Odin's unsafe-return refusal — returning (addr local), (slice local-array …) or (addr (at local-array i)); (B) the same test on a set into a global; (C) dev fills a fixed arena's freed bytes with poison on free-all; (D) detect_stack_use_after_return=1 for @sanitize. Rules out a with-allocator escape check: the runtime epoch check catches it and a static rule flags building into the caller's arena. Probes: p1-p16 of the study. Decided 2026-09-25: a study, not a build — how arena memory escapes in real Flan code, and whether a sound lexical check would catch most of it. The result goes in docs/BUILT.md; nothing is built on it without the author. Open, and for the first time with evidence available: the epoch trap is built, and there is a =Vec= to write real arena programs with, so whether the escapes that @@ -1005,13 +971,10 @@ at all, which is what the diagnosis predicted. A =map= that *changes* the elemen type is the one shape that did not come with them: one copy per ordered pair of types rather than per type. -** NEXT CFn in a struct or a fixed array -Decided 2026-09-25: allowed. A call through a null =CFn= is a named runtime condition on both backends, and parks in a dev build. -A zeroed function value is a null pointer, so a function value is refused in any -position zero-initialisation would conjure one — =CFn= included. An =(Option -(CFn ...))= field is already legal. A table of function pointers is exactly what -=CFn= is for, and the objection is about zero-initialisation rather than about -capture. +** DONE CFn in a struct or a fixed array +CLOSED: [2026-09-25] +A zeroed =CFn= is admitted everywhere and a call through a null one signals +=NullCall= before its arguments run. =(Fn ...)= stays refused in those positions. ** DONE Structural compatibility is identical layout Same fields, same types, same order, so structural compatibility is "the same @@ -1021,15 +984,6 @@ ignore order, writable access has to alias the real storage. Flexible field orde waits for classes deliberately, because a class owns its layout and a =Vector2= should not pay for identity and metadata. Not implemented. -** TODO An error in a called generic's body is reported twice -=(defn g [x $t] u64 (nosuch x))= called once from =main= prints "unknown -function nosuch" twice at the same place and counts 2 errors — once from the -abstract pass and once from the instantiation. - -** TODO A type variable is printed without its $ -=Types.to_string= prints =Var t= as =t=, so a refusal reads "selection-sort -expects [t] here, found [3 i32]" where the source wrote =[$t]=. - ** DONE Two refusals suggested something that does not compile CLOSED: [2026-09-25] =vec-new= and =map-new= with no type no longer say "or give the binding a type"; @@ -1484,9 +1438,10 @@ out the first element typing the rest. * Dev loop -** TODO Every evaluated expression leaves its module mapped -Each C-x C-e loads its own =.so= and never unloads it, so a session's mapping count -grows by about four per evaluation; the kernel's limit (65530) ends a long session. +** WAIT A _ caller whose type follows a redefined callee +Its signature changes in the session but its body is not recompiled, so every call +stops on StaleCall naming a type nobody wrote. Proposal: recompile such callers. +Postponed 2026-09-25 while .fln takes priority. ** TODO A prelude function shadowed live is reached by the prelude's own calls A defn of a prelude function's name sent to a running =flan dev= installs into the @@ -1529,12 +1484,6 @@ A finished program parks instead of dying, and a daemon op wakes it and re-enter Globals are not reset between runs — the process never died. Rules out a fresh process per run. -** NEXT Re-run does not work under --two-process -Decided 2026-09-25: re-run under =--two-process= starts a fresh child, installed redefinitions included, and says that globals start over because the process is new. -A finished child process is genuinely gone, so there is nothing to wake. Re-run is -merged-build only, and since the default backend runs merged it is no longer the -blocked case. - ** DONE An accepted re-run reads as running CLOSED: [2026-09-21] A caller that asked for a re-run and then waited for the program to park was @@ -1570,14 +1519,6 @@ was delivered" is a generation number rather than a name, so evaluating from inside a break into a thunk that stops on the same condition class is settled by comparing two integers. -** NEXT Whose break it is, which no counter answers -Decided 2026-09-25: fix it. A stop records whether the thread that stopped was running the evaluation's thunk or the program's own code, so the sentence is decided by the frame and not by the generation counter. -A game loop that signals during the build or the wait bumps the generation exactly -as a thunk would. The machine-readable fields stay right; what is wrong is the -sentence. The per-frame program-or-eval label is computed by the daemon from -ownership, not from anything in the frame, so this is not the shadow-stack gap it -was once written down as. Not queued — the window is narrow. - ** DONE The first evaluation no longer stalls behind the agent socket The accept loop used to sit behind a ten-second wait for the agent socket, so a program that binds its socket late — or not at all — looked ready and answered @@ -1623,13 +1564,6 @@ prunes a package nothing calls into in a release build. =flan dev= links the agent's C into every program it builds whether or not the source imports it; a release build links it only when the program calls into it. -** NEXT FLAN_AGENT_SOCKET in a shell's environment steals the socket -Decided 2026-09-25: narrow the gate. The daemon also exports its own pid, and the constructor binds the socket only when that pid is the program's parent (or the program itself, in a merged build). -Binding unlinks the path first, and before the constructor that unlink was reached -only by an explicit call. A sentence about the shape of the gate rather than an -observed problem: only the daemon sets the variable and it never runs release -builds. The fix, if it is ever felt, is a narrower gate. - ** DONE The daemon's "has not called (agent/start ...)" note is unreachable CLOSED: [2026-09-25] Retired, with the matching arm of an evaluation's timeout, because it named the @@ -1679,12 +1613,6 @@ a defcustom. The agent keeps the condition pointer beside its name and a verb hands it back, so the editor can render the condition's own fields rather than only its class. -** NEXT The type identity of a local is not qualified -Decided 2026-09-25: a local's type prints package-qualified in the break buffer and the inspector, as a field's and a condition's already do. -Settled for conditions and for structs, because =Load= qualifies every declaration -at import. Still open for locals, where the debug information gives a bare name and -nothing qualifies it. - ** NEXT The render-thunk-per-inspection design Decided 2026-09-25: the inspector reads a value through the type layouts the compiler records, with no compile per inspection, which lets it hold a value. An inspection still compiles a thunk per request. A redesign rather than a @@ -1729,10 +1657,11 @@ out versioned bodies and trampolines, and redirecting a value taken before the change. =main= stays refused: its caller is startup code no cell reaches. docs/BUILT.md, "A signature change installs". -** DONE A module carrying a string literal is never unloaded -The transient rule is that a module retaining nothing may go, and a string literal -counts as something retained — which silently stopped every module carrying one -from ever being unloaded. That is why frame descriptors got their own counter. +** DONE An expression's module is unloaded unless it hands out a constant +CLOSED: [2026-09-25] +A thunk's string literal is a copy the process keeps, and registry names and initial +images are copied by the runtime, so none of them pins the module; a condition's +name or a restart's text still does. Rules out unloading on a guess about a literal. ** DONE A redefinition delivered while parked installs on the next re-run The park used to drain the agent ring only when something had asked it to poll, @@ -1778,13 +1707,6 @@ nothing orders the two. The read raised on a closed socket and the test binary exited 1 with no failure line, which is the worst shape a failure can have when a lane is judged on the exit status. -** NEXT A program driven by a real flan dev daemon under a sanitizer -Decided 2026-09-25: =flan dev --sanitize= builds the host under ASan/UBSan on the LLVM backend (refused by name with =--x86=), and the @sanitize alias gains a case driving a real session through reloads and a break. -The daemon builds its host through its own path and the CLI has no way to pass a -sanitizer flag to it. Named as the check worth adding next; a day rather than an -hour. The x86 backend is not a gap here — that pair is refused by name, because -there is no sanitizer pass over hand-written assembly. - ** DONE A transient signal 11 on a globals daemon CLOSED: [2026-09-25] Not a segfault. The report was OCaml's signal number, and in OCaml's numbering @@ -1836,11 +1758,12 @@ line and every later row unrun. gone. The dev daemon now removes its own on a clean end; the one-shot commands do not. -** TODO An x86 dev session's dyn global sometimes reads wrong after an allocating thunk -test_dev's =--x86: after a thunk that allocates (cycle 1) the parked program's dyn -global reads "kept"= failed once in a full =dune test= on 2026-09-25 and passed three -direct reruns. Intermittent and GC-shaped: a dyn global read after a collection a -C-x C-e thunk triggered. Needs reproducing under load and fixing. +** WAIT An x86 dev session's read of a dyn global after an allocating thunk failed once +WAIT on a recurrence; the test now prints the failing read's own reply. +The one failure's message came from a second read, which said "kept"; the failing +reply itself was not recorded. Not reproduced in 350 churn-and-read cycles under +8-way load, three concurrent test_dev runs, or a valgrind run of the cycle, which +was clean. * Editor @@ -1959,21 +1882,6 @@ CLOSED: [2026-09-25] =put= on an instance still checks a declared slot's type and still inserts an undeclared key; only =set= refuses one, since a slot it writes has to exist. -** NEXT update: change a place by applying a function to it -Decided 2026-09-25: every place evaluates each of its subexpressions once, C's compound-assignment rule, which also fixes =++= and =--=; =update= is built on that. Rules out refusing side effects in a place. -=(set (.velocity g) (inc (.velocity g)))= names the place twice. Clojure's -=update= would be a macro over the same two steps, for a struct field and a -class slot alike. - -Blocked on the double-evaluation question, which =++=, =--= and any -compound assignment share: =(update (at grid (next-index) c) inc)= evaluates -=(next-index)= twice, and a place with a side effect is then wrong rather than -slow. Either places get a general single-evaluation rule — bind every -subexpression of a place to a temp once, which is what C's compound assignment -does — or the language says a place must be side-effect free and refuses -otherwise. The first is the real fix and it is a change to how every place -lowers, not to one macro. - ** TODO A session eval reported (CFn [] ()) does not cross into dyn yet At =sand.flan:46:20=, the =:pause= in =(when (get state :pause) (return))=, where =state= is a =defclass= instance with a =pause= slot. =(CFn [] ())= is @@ -2007,15 +1915,6 @@ maps bind =q=, and the diagnostics map binds =RET= and =q=, so those keys are the mode's own and behave the same under Evil. Every key a mode does not bind itself, including the rest of =special-mode-map=, stays Evil's. -** NEXT Eval in the frame, from the break loop -Decided 2026-09-25: SLIME's eval-in-frame, as described. -An expression is evaluated at a frame boundary, so it sees globals and not the -stopped frame's locals — which are the values anyone stopped there wants. Wants -SLIME's eval-in-frame: pick a frame, and the expression is checked and run with -its slots in scope. The slots are already on the frame and already readable -(=flan_dev_frame_slot=); what is missing is checking an expression against that -frame's names and types. - ** DONE The stack lists prelude frames CLOSED: [2026-09-25] A frame whose location is == is hidden by default, and a line in its @@ -2024,14 +1923,15 @@ because =locals= and the inspector are asked by it. The innermost frame is shown even when it is the prelude's, unless the stop is =(pause)=, because it is where the program stopped. Rules out renumbering the visible frames. -** NEXT There is no stepper -Decided 2026-09-25: stepping happens inside a stopped frame, so the game loop and its clock are frozen, as under =(pause)=. -=(pause)= stops and offers restarts, frames, locals and the inspector, but -nothing advances a form at a time. CIDER instruments a form and steps the -instrumented copy; the equivalent here is a dev-build-only instrumented -redefinition, which the cell indirection already makes deliverable. Open: -whether stepping suspends the frame loop, and what it does to a game's clock. +** DONE C-c C-c reports one error, not every error in the form +CLOSED: [2026-09-25] +Every error at any depth: a refused subexpression stands as a Never that fits +any want, and what it causes is left unsaid. Rules out stopping at a statement boundary. +** DONE There is no stepper +CLOSED: [2026-09-25] +C-c C-s instruments a defn with a step point before each body form; no step +into a callee, no argument positions, and no value shown after a form. ** DONE A NaN cast says "does not fit", which reads as too big CLOSED: [2026-09-25] Two more =ArithError= codes: 5 for a cast of NaN and 6 for a cast of an infinity, @@ -2054,23 +1954,10 @@ rebinds all at once. No other form had the gap: =let= was already sequential, =dotimes= binds one name, and =fn=, =defn=, =match= and the handler and restart clauses bind parameters with no initialisers. -** NEXT C-c C-c reports one error, not every error in the form -Decided 2026-09-25: every error in the form, at any depth. A failed subexpression takes an error type that fits any want, so checking continues around it and the errors it would cause are not reported — Rust's, TypeScript's and Elm's shape. Rules out stopping at a statement boundary. -Whole-file paths use =Check.program_all= and report every bad declaration. The -daemon asks for the sink off (=lib/loc.ml:185=) and gets one exception, so a -function with three bad expressions takes three round trips. The sink is -per-phase; making it per-form would need a resync point inside a body. - ** DONE A session should start before a program compiles CLOSED: [2026-09-25] A file with no =main= starts on a stub =main= that returns and parks; =load-file= (=C-c C-k=, already its key — the inspector stays on =C-c C-i=) keeps what compiles and lists the rest. Rules out =flan dev= with no file at all, and =--two-process= on a file with no =main=. -** NEXT The daemon buffer is navigable but not coloured -Decided 2026-09-25: errors, warnings and notes take compilation-mode's faces, and the program's own output takes a face of its own so it reads apart from the compiler's. -=*flan*= is all plain text. =compilation-minor-mode= is on (=emacs/flan.el:822=) -so =next-error= works, but a minor mode installs no font-lock. Open: whether the -program's output should look different from the compiler's. - ** DONE compilation-mode steps over the notes CLOSED: [2026-09-25] The daemon buffer and the diagnostics buffer set =compilation-skip-threshold= to diff --git a/bin/main.ml b/bin/main.ml index 8e261f3a..baa14c73 100644 --- a/bin/main.ml +++ b/bin/main.ml @@ -799,7 +799,11 @@ let () = which is the point of leaving it readable here — the combination stays refused by name, it is just no longer somewhere you arrive by typing one flag. *) - let x86 = backend_x86 ~default:(not debug) rest in + (* --sanitize takes [--llvm]'s side for the reason [--debug] does: the + sanitizers are LLVM passes. [--x86] written as well is refused by name + in [Dev.start]. *) + let sanitize = List.mem sanitize_flag rest in + let x86 = backend_x86 ~default:(not (debug || sanitize)) rest in let asked_x86 = List.mem x86_flag rest in let merged = not (List.mem two_process_flag rest) in let rest = List.filter (fun a -> not (is_flag a)) rest in @@ -809,8 +813,8 @@ let () = | [] -> Filename.concat (Filename.dirname path) ".flan-dev.sock" | _ -> prerr_endline - "usage: flan dev [-s socket] [--debug] [--llvm] \ - [--two-process]"; + "usage: flan dev [-s socket] [--debug] [--sanitize] \ + [--llvm] [--two-process]"; exit 2 in (* Only this command hands one over, and only when it chose the backend @@ -826,7 +830,7 @@ let () = else None in with_errors ?x86_hint path (fun () -> - Flan.Dev.start ~debug ~merged ~x86 ~file:path ~sock ()) + Flan.Dev.start ~debug ~sanitize ~merged ~x86 ~file:path ~sock ()) (* One redefinition, built the way an editor will ask for it: a session over the program the process was built from, and a file of the forms that diff --git a/docs/BUILT.md b/docs/BUILT.md index 3ded16d5..5a8a18b8 100644 --- a/docs/BUILT.md +++ b/docs/BUILT.md @@ -1045,8 +1045,9 @@ the two builds are *supposed* to differ, since `flan_dev_crash_enable` checks a install the handler when ASan is in the process. So the case asserts ASan's report and the absence of the handler's line, built at `-O0` because at `-O2` a store through a zeroed `(Ptr u8)` is undefined and need not fault. That yield had never run in any build anywhere: it was behind a link that did not happen. Twenty-six seconds of the alias's 2m30 warm. -What it still does not reach is a program driven by a real daemon under ASan: `flan dev` builds its host through its own -path and has no `--sanitize` to pass it. +`dev_session` drives a real `flan dev --sanitize` session — merged, LLVM, the compiler's OCaml in the same process as +the sanitized host — through a break, three reloads and a second break; the modules it sends are still not +instrumented. **Two aliases were green only because `dune test` runs first, and that is the same disease in a different place.** `@sanitize` never listed the package directories `pkg-diamond.flan` imports and `@page` never listed `sand.flan`, which @@ -1821,7 +1822,9 @@ shape TODO.org's "The compiler is a thread inside the program" landed on: **the program's process. It is SLIME's model — you start the image, it serves, the editor connects. `--two-process` is the escape hatch, for a machine where the compiler object cannot be built (no `ocamlfind`, no -`flan.cmxa` beside the binary). It has its own test and it stays. +`flan.cmxa` beside the binary). It has its own test and it stays. A re-run there is a new child built from the session +as it stands, so the redefinitions are in it and the globals start over; the daemon outlives a finished child to take +that request. **The editor socket and its wire protocol did not move.** Emacs cannot tell the difference, which is what made the merge testable: the whole existing suite is the check. @@ -3000,7 +3003,7 @@ fires. The value is two words: the struct's address and the incarnation of it th | `(slice v)` / `(slice v lo)` / `(slice v lo hi)` | a non-owning `[T]` view — the array names again, extended | | `(clone v)` / `(clone v a)` | the only copy; assignment moves | | `(free v)` | consumes its argument | -| `(bytes s)` / `(bytes s a)` | a writable copy of a string's bytes, against the context or a named allocator — an allocating operation like `vec-new`: StorageExhausted with retry, a registry note in dev builds. The answer is a `[u8]` view of the block, so nothing can `free` it through the slice; it lives until its allocator's `free-all` or destroy | +| `(bytes s)` / `(bytes s a)` | a writable copy of a string's bytes, against the context or a named allocator — an allocating operation like `vec-new`: StorageExhausted with retry, a registry note in dev builds. The answer is a `[u8]` view of the block; `(free b)` hands it back to the context allocator, or `(free b a)` to the one named, and a dev build's registry traps on a mismatch | | `(bytes-view s)` | the string's own storage as a `[const u8]`, costing nothing — the old `(bytes s)` reinterpret, renamed. A store through it is a compile error, because a literal's view points into `.rodata` | ### A view of a `Vec` goes stale at the `push`, and nothing checks it @@ -3887,7 +3890,7 @@ before this landed, so `macro-unless.flan` is a test written after the feature. ### The line between a special form and a macro A form the prelude itself relies on is built into the parser: `cond`, `when` and `dotimes`. A form only programs use -is a prelude macro: `inc`, `++`, `into`, `unless`, `until` and `comment`. The reason is `Macro.reduce`: a prelude +is a prelude macro: `inc`, `++`, `update`, `into`, `unless`, `until` and `comment`. The reason is `Macro.reduce`: a prelude function that calls a macro is left out of the module that runs macros, so a form the prelude's own functions use cannot be a macro without taking those functions away from every macro body. `until` peels an optional leading label and answers `(while :label (not test) body ...)`. @@ -4336,8 +4339,9 @@ implemented. refusal's witness now runs. The escape refusal that replaced it is gone too; see "Escape: only an escaping closure's environment is the collector's".* - **An `fn` with nothing to say what it takes** (`fn-no-type.flan`), above. -- **A position that would zero one** (`fn-in-struct.flan`): a struct field, a global, a fixed array's element, - `(zeroed)`. ZII fills an omitted field with all-bytes-zero, and **a zeroed function value is a null pointer, which +- **A position that would zero an `(Fn ...)`** (`fn-in-struct.flan`): a struct field, a global, a fixed array's element, + `(zeroed)`. A `(CFn ...)` is admitted in all four: every call through one tests for null and signals `NullCall` + (`fn-cfn-table.flan`). ZII fills an omitted field with all-bytes-zero, and **a zeroed function value is a null pointer, which is the one kind of zero that is not a value the type can have** — every other type's zero is one: `0`, `false`, an empty slice, `None`, a union's first case. A parameter, a return type and a `let` binding are not on the list because none of them is ever conjured, and an `(Option (Fn ...))` is not either, because a `None`'s tag is what diff --git a/emacs/MANUAL.md b/emacs/MANUAL.md index 987fc20d..a44a8dce 100644 --- a/emacs/MANUAL.md +++ b/emacs/MANUAL.md @@ -236,6 +236,12 @@ breakpoint is just a condition nobody handled. hit it as many times as you like; an ordinary `C-c C-c` over the same form (or `C-c C-k` over the buffer) takes it off. +**Stepping.** `C-c C-s` installs the `defn` at point so that a call stops +before each form of its body. Each stop is a break like `(pause)`, and the +source of the form about to run is shown beside it. `s` goes to the next form, +`c` runs the rest of the call, and the next call steps again. `C-c C-c` over the +same form installs it plain. + `C-u C-x C-e` does the same for the expression before point: it stops *at* the expression instead of printing its value. That one does not stick, because there is no definition for it to stick to. `C-u C-c C-c` on a top-level form that is @@ -375,6 +381,9 @@ Keys in that buffer: | `v` | visit the source of the frame at point | | `P` | show or hide the prelude's frames | | `i` | inspect the local or global at point | +| `e` | evaluate an expression in the frame at point; it sees that frame's locals | +| `s` | at a step, go to the next form | +| `c` | take `continue`: at a step, run the rest of the call | | `a` | abort | | `g` | read the program again | | `q` | close the buffer | @@ -1190,6 +1199,7 @@ Use `C-c C-g` if you need frames. | `C-x C-e` | same, cursor on the line's last character | at a line's end, the innermost statement ending there: a match arm's value, an if/elif/while condition, or the whole statement a header or clause line opens; elsewhere, the term before point | | `C-c C-e` | same | the statement at point with its body and clauses, or the region's whole lines; on a bare `let x = v`, the `let` and the rest of its block | | `C-c C-n` | same | `C-c C-e`, then move to the next statement | +| `C-c C-s` | same | step through the top-level `fn` at point | | `C-c C-k` | same | the whole buffer | | `C-M-a` / `C-M-e` / `C-M-h` | `[[` / `]]` | top-level form: start, end, mark | | `M-a` / `M-e` | `(` / `)` | statement: start / end (`)`: start of the next) | @@ -1206,7 +1216,7 @@ Use `C-c C-g` if you need frames. | — | `is` `as` | statement (`as`: whole lines) | | — | `ii` `ai` | body / whole statement | | — | `ik` `ak` | clause's block / clause | -| — | `id` `ad` | top-level form (`ad`: with the blank lines after it) | +| — | `id` `ad` | top-level form with the comment block directly above it (`ad`: and the empty lines after it, or before it for the last form) | `else`, `elif`, `on` and `restart` snap to their header's column as you type them. `indent-region` and `C-y` move lines only as a block, never one line @@ -1233,6 +1243,7 @@ on plain `smartparens-mode`, which pairs brackets and strings but not `'`. | `C-u C-c C-c` | ...and stop at the form point is inside (`C-u C-u`: on entry) | | `C-M-x` | the same as `C-c C-c`, on the binding SLIME and CIDER use | | `C-c C-k` | load the whole buffer, as one module; what does not compile is listed | +| `C-c C-s` | install the defn at point to stop before each form of its body | | `C-x C-e` | the form before point, evaluated — or installed, if it is a declaration | | `C-u C-x C-e` | ...and stop at it instead of showing its value | | `C-c C-z` | connect (finds `.flan-dev.sock` upward) | diff --git a/emacs/flan-cnr.el b/emacs/flan-cnr.el index 8f29907f..45b8923a 100644 --- a/emacs/flan-cnr.el +++ b/emacs/flan-cnr.el @@ -63,6 +63,7 @@ ;;; Code: (require 'seq) +(require 'pulse) (require 'subr-x) (require 'flan-mode) @@ -170,6 +171,15 @@ nothing in the compiler knows a breakpoint from an error and this buffer is the first place that can tell the difference. Named here rather than spelled at its use, because it is a fact about the prelude.") +(defconst flan-cnr-step "StepPoint" + "The condition the stepper's `(step-point)' signals, before each form of a +defn sent with `C-c C-s'. A stop like `(pause)', with `next' and `continue' +restarts: `s' takes the first and `c' the second.") + +(defun flan-cnr--stepping-p (state) + "Whether STATE is a stop of the stepper." + (equal (plist-get state :condition) flan-cnr-step)) + (defun flan-cnr--headline-fields (fields) "The condition's own numbers, folded into the headline. FIELDS is the fields list; the result is \"low 9, high 9, length 4\" over the @@ -229,7 +239,7 @@ indexing or the division itself, so it sits directly under the headline." ;; only thing that can be wrong here is the word for it. Calling a ;; breakpoint unhandled would be a small lie told at the top of the ;; one buffer that exists to say what happened. - (paused (equal name flan-cnr-breakpoint)) + (paused (member name (list flan-cnr-breakpoint flan-cnr-step))) (numbers (flan-cnr--headline-fields (plist-get state :fields)))) (insert (propertize name 'face (if paused 'warning 'error))) (when numbers (insert " — " numbers)) @@ -240,9 +250,11 @@ indexing or the division itself, so it sits directly under the headline." (let ((sentence (plist-get state :sentence))) (when sentence (insert sentence "\n"))) (insert (propertize - (if paused - "stopped at (pause); nothing has been unwound\n" - "unhandled; stopped where it erred, nothing unwound\n") + (cond + ((flan-cnr--stepping-p state) + "stepping: stopped before the form below; s steps to the next, c runs the rest of the call\n") + (paused "stopped at (pause); nothing has been unwound\n") + (t "unhandled; stopped where it erred, nothing unwound\n")) 'face 'shadow)) (flan-cnr--insert-site state)) (insert "\n") @@ -439,7 +451,8 @@ breakpoint the program's author wrote, not a step of the program." (if (and (not flan-cnr--show-prelude) (flan-cnr--prelude-frame-p fr) (or (> i 0) - (equal (plist-get state :condition) flan-cnr-breakpoint))) + (equal (plist-get state :condition) flan-cnr-breakpoint) + (flan-cnr--stepping-p state))) (setq hidden (1+ hidden)) (when (> hidden 0) (flan-cnr--insert-hidden hidden) @@ -574,7 +587,7 @@ puts the likely culprit on top." ;; an entry is annotated with have to be on screen above it to read. (flan-cnr--insert-globals state) (insert (propertize - "RET/0-9 take RET on a frame visits it TAB fold P prelude frames i inspect a abort g refresh q quit\n" + "RET/0-9 take RET on a frame visits it TAB fold P prelude frames i inspect e eval in frame s step c continue a abort g refresh q quit\n" 'face 'shadow)) (goto-char (point-min)) ;; Point starts on the restart that abandons the evaluation, when there is @@ -833,6 +846,69 @@ drawn from." (`(:expr ,expr) (flan-inspect expr)) (_ (user-error "flan: this line carries no root the inspector knows"))))) +(defun flan-cnr--frame-at-point () + "The index of the frame point is on, or on a local of, or nil." + (or (get-text-property (point) 'flan-cnr-frame) + (pcase (get-text-property (point) 'flan-cnr-inspect) + (`(:slot ,frame . ,_) frame)))) + +(defun flan-cnr-eval-in-frame (frame code) + "Evaluate CODE in stopped FRAME, SLIME's eval-in-frame, and show the value. +CODE sees FRAME's locals as well as the globals, and a `set' of a local +changes the frame. Interactively FRAME is the one point is on, or on a +local of, and CODE is read from the minibuffer." + (interactive + (let ((frame (flan-cnr--frame-at-point))) + (unless frame + (user-error "flan: point is not on a frame — e evaluates in the frame point is on")) + (list frame (read-string (format "Eval in frame %d: " frame))))) + (let ((r (funcall flan-cnr-request-function + (list :op "eval-expr" :frame frame :code code)))) + (if (equal (plist-get r :status) "ok") + (let ((v (or (plist-get r :value) (plist-get r :note) ""))) + ;; A set may have changed what an open frame shows, so each is + ;; asked again the next time it is opened. + (dolist (fr (plist-get flan-cnr--state :stack)) + (when (consp fr) (plist-put fr :fetched nil))) + (message "=> %s" v) + v) + (user-error "flan: %s" (or (plist-get r :message) "refused"))))) + +(defun flan-cnr--take-named (name) + "Take the innermost restart called NAME, or refuse by name." + (let ((i (seq-position (plist-get flan-cnr--state :restarts) name))) + (unless i (user-error "flan: there is no %s restart at this stop" name)) + (flan-cnr--invoke i name))) + +(defun flan-cnr-step () + "Step to the next form: take the stepper's `next' restart." + (interactive) + (flan-cnr--take-named "next")) + +(defun flan-cnr-continue () + "Take the innermost `continue' restart. +At a stepper's stop it runs the rest of the call; at a `(pause)' it resumes." + (interactive) + (flan-cnr--take-named "continue")) + +(defun flan-cnr--step-site (state) + "Where a stepper's STATE stopped: the first frame that is not the prelude's." + (seq-some (lambda (fr) + (and (not (flan-cnr--prelude-frame-p fr)) + (plist-get fr :loc))) + (plist-get state :stack))) + +(defun flan-cnr--show-step-site (state) + "At a stepper's stop, show the form about to run in its source, highlighted. +The break buffer keeps the selection; the source is shown beside it." + (let ((loc (and (flan-cnr--stepping-p state) (flan-cnr--step-site state)))) + (when loc + (ignore-errors + (save-selected-window + (with-current-buffer (flan-visit-loc loc "the step") + (pulse-momentary-highlight-region + (point) (save-excursion (ignore-errors (forward-sexp)) (point))))))))) + (defun flan-cnr-refresh () "Ask the program again what it is offering." (interactive) @@ -889,7 +965,12 @@ anyone who would rather TAB always moved." (define-key map "v" #'flan-cnr-visit) (define-key map "P" #'flan-cnr-toggle-prelude) (define-key map "i" #'flan-cnr-inspect) + ;; SLIME's `e': evaluate in the frame at point. + (define-key map "e" #'flan-cnr-eval-in-frame) (define-key map "a" #'flan-cnr-abort) + ;; The stepper's two, CIDER's `c' and SLIME's `s' (`n' moves). + (define-key map "s" #'flan-cnr-step) + (define-key map "c" #'flan-cnr-continue) (define-key map "g" #'flan-cnr-refresh) (define-key map "q" #'quit-window) ;; Numbered, as SBCL's are, and for SBCL's reason: the names are not @@ -1132,6 +1213,7 @@ walk from a running program." ;; the program running again: see `flan--forget-break-stack'. (setq next-error-last-buffer buf)) (pop-to-buffer buf) + (flan-cnr--show-step-site (buffer-local-value 'flan-cnr--state buf)) buf))) (provide 'flan-cnr) diff --git a/emacs/flan-fln-mode.el b/emacs/flan-fln-mode.el index af056b46..9c69e88c 100644 --- a/emacs/flan-fln-mode.el +++ b/emacs/flan-fln-mode.el @@ -39,7 +39,7 @@ ;; The client, which every command that sends code needs and which this file ;; must not load merely to edit one. -(declare-function flan--eval "flan" (code what &optional start end pause)) +(declare-function flan--eval "flan" (code what &optional start end pause step)) (declare-function flan--eval-expression "flan" (start end arg)) (declare-function flan--text "flan" (start end)) (declare-function flan--text-at "flan" (start end)) @@ -669,31 +669,35 @@ pattern names something, so the value cannot be evaluated alone." (buffer-substring-no-properties (car value) (cdr value)))))))))))) -(defconst flan-fln--name-char "[:alnum:]_?!*/$<>=%+-" - "The characters a name is made of, for a character class.") +(defun flan-fln--names-in (text &optional skip-heads) + "Every name in TEXT, as the syntax table reads names, and each dotted part +of one: `p.x' gives `p.x', `p' and `x'. With SKIP-HEADS, not a name glued to +a `(' -- a pattern's constructor, which binds nothing." + (with-temp-buffer + (set-syntax-table flan-fln-mode-syntax-table) + (insert text) + (goto-char (point-min)) + (let (names) + (while (re-search-forward "\\(?:\\sw\\|\\s_\\)+" nil t) + (let ((n (match-string-no-properties 0))) + (unless (and skip-heads (eq (char-after) ?\()) + (push n names) + (dolist (part (split-string n "\\." t)) + (push part names))))) + (delete-dups names)))) (defun flan-fln--pattern-names (pat) - "The names pattern PAT binds: its lowercase words that are not constants, -fields, keywords, constructors or `_'." - (let ((re (concat "\\(?:\\`\\|[^" flan-fln--name-char ".:]\\)" - "\\([a-z][" flan-fln--name-char "]*\\)")) - (start 0) names) - (while (string-match re pat start) - (let ((n (match-string 1 pat))) - (setq start (match-end 1)) - (unless (or (member n flan--constants) - (and (< start (length pat)) (memq (aref pat start) '(?\( ?.)))) - (push n names)))) - names)) + "The names pattern PAT may bind: every name in it but a constructor head. +Numbers are not names. Generous otherwise -- a keyword or a constant counts +too -- because a name +wrongly counted only sends the whole match, and one missed sends a value +that reads a global of the same name and shows a wrong answer." + (seq-remove (lambda (n) (string-match-p "\\`[-+]?[0-9]" n)) + (flan-fln--names-in pat t))) (defun flan-fln--uses-any-p (names text) - "Non-nil if TEXT has any of NAMES as a whole name." - (seq-some (lambda (n) - (string-match-p (concat "\\(?:\\`\\|[^" flan-fln--name-char ".]\\)" - (regexp-quote n) - "\\(?:\\'\\|[^" flan-fln--name-char "]\\)") - text)) - names)) + "Non-nil if TEXT has any of NAMES as a name, or as part of a dotted one." + (seq-some (lambda (n) (member n names)) (flan-fln--names-in text))) (defun flan-fln--arm-to-send (l arm) "What evaluating the match arm at L sends: its value, or, when its pattern @@ -721,6 +725,18 @@ point's line, when it next runs; with two, on entry." (prog1 (flan--eval-expression (car b) (cdr b) arg) (pulse-momentary-highlight-region (car b) (cdr b))))))) +;;;###autoload +(defun flan-fln-step-defun () + "Install the top-level form at point so a call stops before each form. +`flan-step-defun' for a .fln buffer: the same stepper, over this syntax's +top-level form." + (interactive) + (flan-fln--client) + (let* ((b (flan-fln--toplevel-bounds (point))) + (head (and b (flan-fln--declaration-head-at (car b) flan--defun-heads)))) + (unless head (user-error "flan: no fn at point to step through")) + (flan--eval (flan--text (car b) (cdr b)) "form" (car b) (cdr b) nil t))) + (defun flan-fln--point-for-last () "Point, or under Evil's normal state the position after the cursor's char. The cursor sits *on* the last character of a line, never after it." @@ -1450,6 +1466,7 @@ it, so a block pasted at another depth stays one block." (define-key map (kbd "C-x C-e") #'flan-fln-eval-last) (define-key map (kbd "C-c C-e") #'flan-fln-eval-statement) (define-key map (kbd "C-c C-n") #'flan-fln-eval-statement-and-next) + (define-key map (kbd "C-c C-s") #'flan-fln-step-defun) ;; The sentence keys, because a statement is this syntax's sentence. ;; M-e shadows a global binding of the same key, as any mode's M-e would. (define-key map (kbd "M-a") #'flan-fln-backward-statement) @@ -1539,17 +1556,53 @@ that says so and otherwise is its own." "B's lines, from the start of the first to the start of the line after." (and b (flan-fln--lines (flan-fln--bol (car b)) (flan-fln--bol (cdr b))))) +(defun flan-fln--empty-line-p (pos) + (save-excursion (goto-char (flan-fln--bol pos)) (looking-at-p "[ \t]*$"))) + +(defun flan-fln--comment-line-p (pos) + (and (flan-fln--blank-p pos) (not (flan-fln--empty-line-p pos)))) + +(defun flan-fln--with-comments (b) + "Whole lines B, and the comment lines directly above them: a comment block +with no blank line under it belongs to what it sits on." + (and b (save-excursion + (goto-char (car b)) + (while (and (zerop (forward-line -1)) + (flan-fln--comment-line-p (point))) + (setq b (cons (point) (cdr b)))) + b))) + +(defun flan-fln--commented-toplevel (pos) + "The top-level form at POS, whole lines with its comment block. +On a comment block that sits directly on a form, that form." + (let ((pos (save-excursion + (goto-char pos) + (beginning-of-line) + (while (and (flan-fln--comment-line-p (point)) + (zerop (forward-line 1)))) + (if (flan-fln--toplevel-start-p (point)) (point) pos)))) + (flan-fln--with-comments + (flan-fln--whole-lines (flan-fln--toplevel-bounds pos))))) + (defun flan-fln--with-trailing-blanks (b) - "B's whole lines and the blank lines after them. -With none after -- the last form -- the blank lines before it instead, as -Vim's `dap' does, so the buffer does not end in empty lines." - (and b (let ((n (flan-fln--next-code (1- (cdr b))))) - (if n - (cons (car b) n) - (let ((p (flan-fln--prev-code (car b)))) - (cons (if p (save-excursion (goto-char p) (line-beginning-position 2)) - (car b)) - (point-max))))))) + "Whole lines B and the empty lines after them. +When nothing follows -- the last form -- the empty lines before it as well, +as Vim's `dap' does, so the buffer does not end in empty lines. A comment +below a form is not taken: it belongs to what follows." + (and b (save-excursion + (goto-char (cdr b)) + (while (and (not (eobp)) (flan-fln--empty-line-p (point)) + (zerop (forward-line 1)))) + (let ((end (point))) + (if (< end (point-max)) + (cons (car b) end) + (goto-char (car b)) + (while (and (zerop (forward-line -1)) + (flan-fln--empty-line-p (point)))) + (cons (if (flan-fln--empty-line-p (point)) + (point) + (min (car b) (line-beginning-position 2))) + end)))))) (defun flan-fln--term-around (b) "B and the spaces after it, or before it when none follow." @@ -1578,9 +1631,10 @@ Vim's `dap' does, so the buffer does not end in empty lines." "A statement, from its first character to its last." (flan-fln--evil (bounds-of-thing-at-point 'flan-fln-statement) 'exclusive)) (evil-define-text-object flan-fln-a-statement (count &optional _beg _end _type) - "A statement's whole lines." - (flan-fln--evil (flan-fln--whole-lines - (bounds-of-thing-at-point 'flan-fln-statement)) + "A statement's whole lines, with the comment block on it." + (flan-fln--evil (flan-fln--with-comments + (flan-fln--whole-lines + (bounds-of-thing-at-point 'flan-fln-statement))) 'line)) (evil-define-text-object flan-fln-inner-body (count &optional _beg _end _type) "A statement's block, its lines." @@ -1607,15 +1661,12 @@ Vim's `dap' does, so the buffer does not end in empty lines." (bounds-of-thing-at-point 'flan-fln-clause)) 'line)) (evil-define-text-object flan-fln-inner-toplevel (count &optional _beg _end _type) - "A top-level form, its lines." - (flan-fln--evil (flan-fln--whole-lines - (bounds-of-thing-at-point 'flan-fln-toplevel)) - 'line)) + "A top-level form, its lines, with the comment block on it." + (flan-fln--evil (flan-fln--commented-toplevel (point)) 'line)) (evil-define-text-object flan-fln-a-toplevel (count &optional _beg _end _type) - "A top-level form and the blank lines after it." + "A top-level form with its comment block, and the empty lines after it." (flan-fln--evil (flan-fln--with-trailing-blanks - (flan-fln--whole-lines - (bounds-of-thing-at-point 'flan-fln-toplevel))) + (flan-fln--commented-toplevel (point))) 'line))) t) (evil-define-key* '(operator visual) flan-fln-mode-map diff --git a/emacs/flan-mode.el b/emacs/flan-mode.el index f5638d0d..1efff081 100644 --- a/emacs/flan-mode.el +++ b/emacs/flan-mode.el @@ -87,6 +87,7 @@ ;; wiring they need. (autoload 'flan-inspect "flan-inspect" nil t) (autoload 'flan-cnr-show "flan-cnr" nil t) +(autoload 'flan-step-defun "flan" nil t) (autoload 'flan-doc "flan" nil t) (autoload 'flan "flan" nil t) (autoload 'flan-quit "flan" nil t) @@ -446,6 +447,8 @@ For `syntax-propertize-function'." (let ((map (make-sparse-keymap))) ;; Autoloaded from flan.el, so the client loads on first use. (define-key map (kbd "C-c C-k") #'flan-eval-buffer) + ;; The stepper: the defn at point, installed to stop before each form. + (define-key map (kbd "C-c C-s") #'flan-step-defun) (define-key map (kbd "C-c C-z") #'flan-connect) (define-key map (kbd "C-c C-q") #'flan-disconnect) (define-key map (kbd "C-c C-d") #'flan-describe) diff --git a/emacs/flan.el b/emacs/flan.el index 21040988..6f5f576e 100644 --- a/emacs/flan.el +++ b/emacs/flan.el @@ -412,6 +412,34 @@ nil keeps everything." (let ((inhibit-read-only t)) (delete-region (point-min) (line-beginning-position))))))) +(defface flan-output-face '((t :inherit font-lock-string-face)) + "Face for the running program's own output in the daemon's buffer. +It sets that output apart from what the compiler and the daemon say, whose +errors, warnings and notes take `compilation-mode''s faces." + :group 'flan) + +(defun flan--daemon-buffer-setup () + "Make the current buffer the daemon's log: navigable and coloured. +The daemon writes a diagnostic as `file:line:col: message', the shape +`compilation-minor-mode' already reads, so it only has to be switched on. +The minor mode adds its font-lock rules but turns nothing on, and a process +buffer is in `fundamental-mode', which global font-lock skips; so font-lock +is switched on here, first, or the rules would never be drawn." + (font-lock-mode 1) + ;; A log, not source: a quote the program printed opens no string. + (setq-local font-lock-keywords-only t) + ;; Only the compiler's own shape, `file:line:col:', is a diagnostic here. + ;; compile.el's other rules are for a build log: one of them draws any + ;; line starting `word:' as a program name, which is every `score: 10' + ;; the program prints. + (setq-local compilation-mode-font-lock-keywords nil) + (setq-local compilation-error-regexp-alist + '(("^\\([^ \t\n:][^\t\n:]*\\):\\([0-9]+\\):\\([0-9]+\\): \ +\\(?:\\(warning\\)\\|\\(note\\|info\\)\\)?" + 1 2 3 (4 . 5)))) + (compilation-minor-mode 1) + (flan--navigable-notes)) + (defun flan--append-output (text) "Append TEXT, the running program's own output, where it can be read. Two places. The daemon's log always gets it, so output lands somewhere @@ -423,7 +451,13 @@ open, above its prompt, which is where whoever is typing there is looking." (inhibit-read-only t)) (save-excursion (goto-char (point-max)) - (insert text)) + ;; Marked as it is inserted, because nothing in the text says whose + ;; it is. A line the program prints in the diagnostic shape is + ;; still read as one by `compilation-minor-mode', and takes its + ;; face. `face' for a buffer with font-lock off, `font-lock-face' + ;; so fontification does not strip it. + (insert (propertize text 'face 'flan-output-face + 'font-lock-face 'flan-output-face))) (flan--trim-lines) ;; Follow the tail only for someone who was already at it; a reader ;; scrolled back is reading something. @@ -893,8 +927,7 @@ It builds the program first, which for a cold project is most of this." ;; program runs, and `compilation-mode' would claim it as the output of ;; one finished command — killing the process on a `recompile', among ;; other things it has no business doing to a live session. - (compilation-minor-mode 1) - (flan--navigable-notes)) + (flan--daemon-buffer-setup)) (make-process :name "flan-daemon" :buffer buf :command args @@ -2566,7 +2599,7 @@ signature, listed in %s" (user-error "flan: %s%s" (or msg "rejected") (if loc (format " (%s)" loc) ""))))) -(defun flan--eval (code what &optional start end pause) +(defun flan--eval (code what &optional start end pause step) "Send CODE to the running program. WHAT names it for the echo area. START and END, when given, are the region it came from, flashed on success. PAUSE, when given, is (BEG . END): the bounds of the form inside CODE the @@ -2582,11 +2615,20 @@ breakpoint is marked from the editor, without editing the buffer\"." (list :op "eval" :code code :file (or buffer-file-name "") :syntax (flan--syntax)) (when pause - (list :pause (flan--wire-position (car pause)))))))) + (list :pause (flan--wire-position (car pause)))) + (when step (list :step t)))))) ;; END as the place a value could go. Every caller of this sends a ;; declaration and declarations have no value, so this is the path that ;; stays open rather than one anybody takes today. - (flan--report reply what end) + ;; + ;; A form with several errors is refused with all of them under + ;; `:errors'; `flan--report' marks and signals the first, and the rest + ;; are marked beside it before the signal leaves, as `C-c C-k' does. + (condition-case err + (flan--report reply what end) + (user-error + (flan--report-load-errors (cdr (plist-get reply :errors)) t) + (signal (car err) (cdr err)))) ;; `flan--report' signals on a rejection, so reaching here means it ;; landed. Flashing the text that was sent answers "which form did that ;; take?" — the question the echo area cannot, because point may be nowhere @@ -2601,6 +2643,10 @@ breakpoint is marked from the editor, without editing the buffer\"." (cond ((and pause (plist-get reply :pause)) (flan--show-pause (car pause) (cdr pause))) + ;; An instrumented defn is marked whole, as a pause mark is, and an + ;; ordinary C-c C-c of it takes the mark down with the instrumentation. + ((and step start end (plist-get reply :step)) + (flan--show-pause start end)) ((and start end) (flan-clear-pause start end))) reply)) @@ -2894,6 +2940,20 @@ declaration for it to live in." ;; `flan--report' signals on a rejection. (pulse-momentary-highlight-region (car b) end)))))) +;;;###autoload +(defun flan-step-defun () + "Install the defn at point so that a call stops before each form of its body. +A stepper, CIDER's `C-u C-M-x': each stop is a break like `(pause)', with the +program and its clock frozen, and the break buffer shows the form about to +run. There `s' steps to the next form and `c' runs the rest of the call; the +next call steps again. `C-c C-c' on the defn installs it plain." + (interactive) + (let* ((b (flan--defun-bounds)) + (head (and (< (car b) (cdr b)) + (flan--declaration-head-at (car b) flan--defun-heads)))) + (unless head (user-error "flan: no defn at point to step through")) + (flan--eval (flan--text (car b) (cdr b)) "form" (car b) (cdr b) nil t))) + ;;;###autoload (defun flan-eval-buffer () "Load this buffer into the running program, as `C-c C-k' does in SLIME and CIDER. diff --git a/emacs/test-flan-cider.el b/emacs/test-flan-cider.el index f65a1b86..c158bdbb 100644 --- a/emacs/test-flan-cider.el +++ b/emacs/test-flan-cider.el @@ -1477,6 +1477,114 @@ would be overwritten. Look again and re-do the edit") (test-flan--check "nothing is evaluated as an expression" (null (plist-get (car asked) :code)))))) +;; `e' evaluates in the frame point is on, or on a local of: the request +;; names that frame, and the value comes back to the echo area. +(let* ((asked nil) + (flan-cnr-request-function + (lambda (form) (push form asked) '(:status "ok" :value "8")))) + (with-current-buffer (test-flan--cnr + (list :condition "Missing" :restarts '("retry") + :stack (list (list :fn "g" :fetched t + :locals '(("b" "i64" "1" 4))) + (list :fn "f" :fetched t + :locals '(("n" "i64" "7" 0)))))) + (goto-char (point-min)) + (search-forward " 1: > f") + (flan-cnr-toggle-frame) + (goto-char (point-min)) + (search-forward " 1: v f") + (search-forward "i64 n") + (let ((said (cl-letf (((symbol-function 'read-string) (lambda (&rest _) "(+ n 1)")) + ((symbol-function 'message) + (lambda (fmt &rest args) (apply #'format fmt args)))) + (call-interactively #'flan-cnr-eval-in-frame)))) + (test-flan--check "`e' on a local evaluates in that local's frame" + (and (equal (plist-get (car asked) :op) "eval-expr") + (= 1 (plist-get (car asked) :frame)) + (equal (plist-get (car asked) :code) "(+ n 1)"))) + (test-flan--check "and answers the value" + (equal said "8"))) + (test-flan--check "`e' is the break buffer's own key" + (eq (lookup-key flan-cnr-mode-map "e") #'flan-cnr-eval-in-frame)))) + +;; The stepper's stop: said as a step, the prelude's own frame hidden, and +;; `s' and `c' take its `next' and `continue' by index. +(let* ((asked nil) + (flan-cnr-request-function + (lambda (form) (push form asked) '(:status "ok")))) + (with-current-buffer (test-flan--cnr + (list :condition "StepPoint" + :restarts '("next" "continue" "continue") + :stack (list (list :fn "step-point" :loc ":250:3") + (list :fn "step" :loc "/s.flan:1:19")))) + (let ((text (buffer-string))) + (test-flan--check "a step's headline says it is stepping" + (string-match-p "stepping: stopped before the form" text)) + (test-flan--check "and the prelude's step-point frame is hidden" + (not (string-match-p "step-point" text)))) + (test-flan--check "the step site is the stepped frame's location" + (equal (flan-cnr--step-site flan-cnr--state) "/s.flan:1:19")) + (save-window-excursion (flan-cnr-step)) + (test-flan--check "`s' takes next" + (and (equal (plist-get (car asked) :op) "restart-at") + (equal (plist-get (car asked) :name) "next") + (= 0 (plist-get (car asked) :index))))) + (with-current-buffer (test-flan--cnr + (list :condition "StepPoint" + :restarts '("next" "continue" "continue"))) + (save-window-excursion (flan-cnr-continue)) + (test-flan--check "`c' takes the innermost continue" + (and (equal (plist-get (car asked) :name) "continue") + (= 1 (plist-get (car asked) :index))))) + (test-flan--check "`s' and `c' are the break buffer's own keys" + (and (eq (lookup-key flan-cnr-mode-map "s") #'flan-cnr-step) + (eq (lookup-key flan-cnr-mode-map "c") #'flan-cnr-continue)))) + +;; Every key flan-mode binds has a row in the manual's key reference. +(let ((text (with-temp-buffer + (insert-file-contents + (expand-file-name "MANUAL.md" + (file-name-directory (locate-library "flan-mode")))) + (buffer-string))) + (missing nil)) + (map-keymap + (lambda (k d) + (when (and (eq k ?\C-c) (keymapp d)) + (map-keymap + (lambda (k2 d2) + (when (commandp d2) + (let ((desc (replace-regexp-in-string + "RET" "C-m" + (replace-regexp-in-string + "TAB" "C-i" (key-description (vector k k2)))))) + (unless (string-match-p (regexp-quote (format "| `%s` |" desc)) text) + (push desc missing))))) + d))) + flan-mode-map) + (test-flan--check (format "every C-c key has a row in the manual (missing %s)" missing) + (null missing))) + +;; C-c C-s sends the defn at point for stepping and marks it. +(let ((sent nil)) + (with-temp-buffer + (flan-mode) + (insert "(defn step [] i64\n (set ticks 1)\n ticks)\n") + (goto-char (point-min)) + (forward-line 1) + (cl-letf (((symbol-function 'flan--request) + (lambda (form) (setq sent form) + '(:status "ok" :fns ("step") :names ("step") :step t))) + ((symbol-function 'flan-refresh-defs) #'ignore)) + (flan-step-defun)) + (test-flan--check "C-c C-s sends the defn with :step" + (and (equal (plist-get sent :op) "eval") + (plist-get sent :step) + (string-prefix-p "(defn step" (plist-get sent :code)))) + (test-flan--check "and marks it as instrumented" + (flan--pause-overlays)) + (test-flan--check "C-c C-s is flan-mode's key for it" + (eq (lookup-key flan-mode-map (kbd "C-c C-s")) #'flan-step-defun)))) + ;; `flan-cnr-show' refuses a running program by name rather than opening an ;; empty buffer. ;; The layout without the values: what a `layout' op alone would buy. The diff --git a/emacs/test-flan-fln.el b/emacs/test-flan-fln.el index c92e05c2..eb1c7b51 100644 --- a/emacs/test-flan-fln.el +++ b/emacs/test-flan-fln.el @@ -308,6 +308,20 @@ comment(): fn twice(n: i64) -> i64 = n * 2 ") +(test-flan-fln--in (test-flan-fln--at test-flan-fln--prog "fib(n - 1)") + (test-flan--check "C-c C-s is the .fln stepper" + (eq (key-binding (kbd "C-c C-s")) 'flan-fln-step-defun)) + (let ((r (test-flan-fln--sending (flan-fln-step-defun)))) + (test-flan--check "which installs the fn at point to step through" + (and (equal (plist-get r :op) "eval") + (eq (plist-get r :step) t) + (string-prefix-p "fn fib" (test-flan-fln--sent-code r)) + (string-suffix-p "fib(n - 2)" (test-flan-fln--sent-code r)))))) +(test-flan-fln--in (test-flan-fln--at test-flan-fln--prog "twice(4)") + (test-flan--check "and refuses what is not a declaration" + (condition-case nil + (progn (test-flan-fln--sending (flan-fln-step-defun)) nil) + (user-error t)))) (test-flan-fln--in (test-flan-fln--at test-flan-fln--prog "fib(n - 1)") (let ((r (test-flan-fln--sending (flan-fln-eval-defun)))) (test-flan--check "C-c C-c inside a fn installs the whole fn" @@ -487,7 +501,7 @@ comment: (let ((r (test-flan-fln--sending (funcall fn)))) (and r (test-flan-fln--sent-code r))))) -(test-flan-fln--is "an arm's value wrapped onto a second line goes whole, moved right" +(test-flan-fln--is "an arm's value wrapped onto a second line goes whole" (test-flan-fln--wrapped-at "None" #'flan-fln-eval-last) "1 +\n 2") (test-flan-fln--is "from its second line too" @@ -516,6 +530,17 @@ comment: (test-flan-fln--wrapped-at "Some(_)" #'flan-fln-eval-last) "5") (test-flan-fln--is "nor one whose value does not use what it binds" (test-flan-fln--wrapped-at "Some(m)" #'flan-fln-eval-last) "7") +(dolist (c '(("Some(_v) -> _v + 1" "a name starting with _") + ("Some(éé) -> éé" "a name that is not ASCII") + ("Some(N) -> N" "a capitalised name") + ("Some(p) -> p.x" "a name used as a field's base"))) + (test-flan-fln--in (concat "fn f(o: Option(i64)) -> i64\n match o\n " (car c) "\n") + (goto-char (point-max)) + (skip-chars-backward "\n") + (test-flan--check (format "an arm binding %s its value uses sends the match" (cadr c)) + (string-prefix-p "match o" + (test-flan-fln--sent-code + (test-flan-fln--sending (flan-fln-eval-last))))))) (test-flan--check "one whose value uses its binding sends the match" (string-prefix-p "match o" (test-flan-fln--wrapped-at "Some(n)" #'flan-fln-eval-last))) @@ -835,6 +860,35 @@ comment: ("dad" "fn g" "fn f(x: i64) -> i64\n if x > 0\n a\n else\n 3\n x\n"))) (test-flan-fln--is (format "under Evil, %s leaves no blank line" (car c)) (funcall deleted (car c) (nth 1 c)) (nth 2 c)))) + ;; Comments: a block directly on a form is the form's; one a + ;; blank line away, or below it, is not. + (let ((deleted + (lambda (keys needle) + (let ((b (generate-new-buffer "comments.fln"))) + (switch-to-buffer b) + (insert "; loose\n\n; on f\nfn f() -> ()\n a()\n; after f\n\n" + "; on g\nfn g() -> ()\n ; on b\n b()\n") + (flan-fln-mode) + (evil-initialize-state) + (evil-normal-state) + (goto-char (point-min)) + (search-forward needle) + (goto-char (match-beginning 0)) + (execute-kbd-macro keys) + (prog1 (buffer-string) + (set-buffer-modified-p nil) + (kill-buffer b)))))) + (dolist (c '(("dad" "a()" + "; loose\n\n; after f\n\n; on g\nfn g() -> ()\n ; on b\n b()\n") + ("dad" "b()" + "; loose\n\n; on f\nfn f() -> ()\n a()\n; after f\n") + ("did" "on g" + "; loose\n\n; on f\nfn f() -> ()\n a()\n; after f\n\n") + ("das" "b()" + "; loose\n\n; on f\nfn f() -> ()\n a()\n; after f\n\n; on g\nfn g() -> ()\n"))) + (test-flan-fln--is (format "under Evil, %s on %s keeps comments with their forms" + (car c) (nth 1 c)) + (funcall deleted (car c) (nth 1 c)) (nth 2 c)))) (let ((b (generate-new-buffer "keys.fln"))) (switch-to-buffer b) (insert "fn f() -> i32 = 1\n") diff --git a/emacs/test-flan.el b/emacs/test-flan.el index 86982546..7712e455 100644 --- a/emacs/test-flan.el +++ b/emacs/test-flan.el @@ -533,6 +533,43 @@ already rely on it — so nothing here is a stand-in for the real thing." ;; The session is not poisoned by that: a good form still lands. (flan--eval "(defn step [] i64 (set ticks (+ ticks 100)) ticks)" "form") + ;; The daemon's buffer is coloured: the compiler's errors, warnings and + ;; notes take compilation's faces and the program's own output takes + ;; `flan-output-face'. Checked on `font-lock-face', which is what + ;; fontification writes; batch Emacs cannot turn `font-lock-mode' on, so + ;; nothing here aliases it to `face'. + (let ((flan-daemon-buffer " *flan-colour-test*")) + (with-current-buffer (get-buffer-create flan-daemon-buffer) + (insert "flan dev: built x.flan in 3ms\n" + "/tmp/a.flan:2:8: expected i32, found string\n" + "/tmp/a.flan:3:1: warning: w\n" + "/tmp/a.flan:4:1: note: n\n") + (flan--daemon-buffer-setup) + (flan--append-output "said hi\nscore: 10\n") + (font-lock-ensure) + (let ((face-on (lambda (text) + (goto-char (point-min)) + (search-forward text) + (get-text-property (match-beginning 0) 'font-lock-face)))) + (test-flan--check + "the daemon's buffer draws an error, a warning and a note in compilation's faces" + (and (memq 'compilation-error (ensure-list (funcall face-on "a.flan:2"))) + (memq 'compilation-warning (ensure-list (funcall face-on "a.flan:3"))) + (memq 'compilation-info (ensure-list (funcall face-on "a.flan:4"))))) + (test-flan--check + "the program's output takes its own face" + (eq (funcall face-on "said") 'flan-output-face)) + (test-flan--check + "a line of output shaped `word:' is not drawn as a program name" + (progn (goto-char (point-min)) (search-forward "score") + (and (null (get-text-property (match-beginning 0) 'face)) + (eq (get-text-property (match-beginning 0) 'font-lock-face) + 'flan-output-face)))) + (test-flan--check + "the daemon's own line is left plain" + (null (funcall face-on "flan dev:"))))) + (kill-buffer flan-daemon-buffer)) + ;; The program's own output arrives on replies and lands in the daemon's ;; buffer — no REPL is open yet, and the log is the fallback that makes a ;; println never depend on one. diff --git a/lib/ast.ml b/lib/ast.ml index bc5f0d67..824d743d 100644 --- a/lib/ast.ml +++ b/lib/ast.ml @@ -24,6 +24,9 @@ and texpr_kind = them identically — the difference is a fact about the value, and it is [Check.resolve] that turns it into one. *) | Tfn of bool * texpr list * texpr + (* An integer written as a generic struct's argument, the 8 in + (Small 8 i32). Parsed only there; it is not a type anywhere else. *) + | Tlen of int64 (* An array length is an integer or a compile-time constant's name. *) and len = @@ -481,6 +484,71 @@ let map_children f (e : expr) : expr = let pause_call loc = { e = Call ({ e = Var "pause"; loc }, []); loc } +(* The stepper. [instrument_step ds] is [ds] with every [defn] rebuilt so a + call stops before each form of its body, at any depth of body: the forms of + a [do], a [let], a loop, a [match] arm and each branch of an [if]. Not + inside an argument, an [fn] or a handler clause, which are not forms a + person reads as steps, and the last two are functions of their own. [None] + when there is no [defn] to instrument. + + A step is [(step-point)] from the prelude — [error] of a [StepPoint] under a + [restart-case], so the break loop takes it as it takes [(pause)], with the + game loop and its clock frozen. It answers whether to go on stepping: its + [next] restart says yes and its [continue] says no, and the answer is kept + in a local of the call, [flan~step], so [continue] runs the rest of this + call and the next call steps again. [~] cannot occur in a source symbol, so + the local is visibly the compiler's and hidden from the locals listing. *) +let step_flag = "flan~step" + +let step_point loc = + let v = { e = Var step_flag; loc } in + { e = + If (v, + { e = Set (Pvar step_flag, { e = Call ({ e = Var "step-point"; loc }, []); loc }); + loc }, + None); + loc } + +let rec step_body (es : expr list) : expr list = + List.concat_map (fun (e : expr) -> [ step_point e.loc; step_expr e ]) es + +and step_expr (e : expr) : expr = + let branch (x : expr) = + match x.e with + | Do _ -> step_expr x + | _ -> { e = Do [ step_point x.loc; step_expr x ]; loc = x.loc } + in + match e.e with + | Do es -> { e with e = Do (step_body es) } + | Let (bs, es) -> { e with e = Let (bs, step_body es) } + | If (c, a, b) -> { e with e = If (c, branch a, Option.map branch b) } + | While (l, c, es) -> { e with e = While (l, c, step_body es) } + | Loop (bs, es) -> { e with e = Loop (bs, step_body es) } + | Dotimes (l, n, b, es) -> { e with e = Dotimes (l, n, b, step_body es) } + | Match (sc, arms) -> + { e with e = Match (sc, List.map (fun a -> { a with body = step_body a.body }) arms) } + | _ -> e + +let instrument_step (ds : decl list) : decl list option = + let hit = ref false in + let ds = + List.map + (fun (d : decl) -> + match d.d with + | Defn f -> + hit := true; + let on = + { bname = step_flag; bty = None; + bval = { e = Var "true"; loc = d.dloc }; bloc = d.dloc } + in + { d with + d = Defn { f with fbody = [ { e = Let ([ on ], step_body f.fbody); + loc = d.dloc } ] } } + | _ -> d) + ds + in + if !hit then Some ds else None + (* [mark_pause ~line ~col ds] is [ds] with a [(pause)] put in front of whatever starts at that position, or [None] when nothing does. diff --git a/lib/check.ml b/lib/check.ml index 9ca97cf7..3aa48fab 100644 --- a/lib/check.ml +++ b/lib/check.ml @@ -79,6 +79,54 @@ let rec slot_text = function | Sclass c -> c | Sopt s -> "(Option " ^ slot_text s ^ ")" +(* Where [sep] first occurs in [m]. *) +let find_sub m sep = + let n = String.length m and k = String.length sep in + let rec go i = + if i + k > n then None + else if String.sub m i k = sep then Some i + else go (i + 1) + in + go 0 + +(* ── Generic structs ───────────────────────────────────────────────── + [(defstruct Small [items [$n $t] count i32])] is a template, not a type. + Its parameters are the sigil names its fields introduce, in the order + first written — [$n] then [$t] here, so the type is spelled + [(Small 8 i32)] — and each is a length or a type by where it stands: in an + array's length slot, or in a generic struct's length argument, it is a + length; anywhere else a type. + + Each application at concrete arguments is a copy: an ordinary struct under + a symbol-safe key, [Small-8-i32], so layout, both backends, the renderer + and DWARF see a struct and nothing else — the same arrangement a generic + function's copy has. [struct_apps] is how the checker still knows what a + copy was applied to, which is what binding [(defn push [s (Ptr (Small $n + $t))] ...)] against an argument needs. An application at variables is a + copy too, under a key with the variables in it, whose array lengths are + [abstract_len]; it exists for the abstract pass over a generic body and is + left out of the program. *) +type gstruct = { + gparams : (string * bool) list; (* name, and whether it is a length *) + gfields : Ast.field list; + gloc : Loc.t; +} + +(* Key -> the generic struct and the arguments it was applied to; a length + argument is [Types.Len], a variable one [Types.Var]. Global for the reason + [Types.display] is: [bind_ty] and [subst_ty] are called from places with no + env in hand. The key is made from exactly these, so an entry can only + mislead where a later program in the same process declares a struct under + a copy's key by hand, and [struct_copy] refuses that name the moment the + program asks for the copy itself. *) +let struct_apps : (string, string * Types.t list) Hashtbl.t = Hashtbl.create 16 + +(* The length every length variable has inside a generic body's abstract + pass. Large so that no constant index into such an array is refused as out + of bounds there, and within i32 so that [(length a)] is an ordinary index. + Every length is answered again, exactly, per copy. *) +let abstract_len = 2147483647L + type env = { structs : (string, Tast.structure) Hashtbl.t; datas : (string, Tast.data) Hashtbl.t; @@ -192,13 +240,47 @@ type env = { chain. Odin has no cap of its own to copy, so there was nothing to borrow. *) mutable chain : (string * Types.t list * Loc.t) list; + (* Generics whose abstract pass was refused and recorded, in a whole-file + check that goes on after a refusal. A call site still gets a copy's + signature, but its body is not checked again: every refusal the abstract + pass made would come back from the copy, at the same line, once per type + it was called at. *) + refused_generics : (string, unit) Hashtbl.t; + (* The generic structs, by name; see [gstruct]. *) + gstructs : (string, gstruct) Hashtbl.t; + (* The struct copies this env made, by key, and whether each is one at + variables — those are left out of the program. *) + copies : (string, bool) Hashtbl.t; + (* Templates whose own check was refused while [deferred] was collecting: + a use of one is a copy with no fields, so the refusal is said once, at + the defstruct, and nothing downstream repeats it. *) + broken : (string, unit) Hashtbl.t; + (* While a whole-file check collects every error, the refusals [collect] + can go on past — a generic struct's template, a where clause over a + length — are kept here instead of ending the pass. [None] everywhere + else, where they raise as before. *) + mutable deferred : Loc.diag list option; + (* A generic defn's length variables, by name: the ones of its [gsigs] + variables that are lengths. *) + glens : (string, string list) Hashtbl.t; + (* Which of [tyvars] are lengths. A length variable is also a value inside + the body — [n] reads as the integer it was bound to. *) + mutable lenvars : string list; + (* Set while a generic body is checked abstractly, and while a struct copy + at variables is laid out: a length variable's array is then + [abstract_len] long rather than the [Types.LArray] a signature pattern + needs. *) + mutable len_placeholder : bool; + (* The struct copies being laid out, innermost last, so a template that + asks for a copy of itself at a bigger type is refused rather than + followed forever. *) + mutable schain : (string * Types.t list) list; (* Set while a struct, data-case or union field's type is being resolved, and only then. It exists for one message: an unknown lowercase name in a type slot is told to introduce a type variable with [$name] in the - parameter vector, and a field has no parameter vector — only a defn - signature binds, and a field is built at one type for every value. The - flag is what lets [resolve_name] say the honest thing in each place - instead of a suggestion that cannot be followed. *) + parameter vector, and a field has no parameter vector — a defstruct's + field introduces one where it stands. The flag is what lets + [resolve_name] say the honest thing in each place. *) mutable in_field : bool; (* Every [defclass], by name: its slots in constructor order, each with the type a value stored in it must have — [Types.Dyn] for a slot written @@ -211,6 +293,19 @@ type env = { the declare-c forms before [Shim.expand] rewrites them. Keyed by the Flan name a program calls. *) tracks : (string, Shim.track) Hashtbl.t; + (* Recovery: checking goes on past a refused subexpression. See [check]. + [recovering] is on only while a whole-file or session check is collecting + every error; [recovered] is what it found, newest first; [poison] counts + failed subexpressions and reads of what they were bound to, which is how + an error caused by an earlier one is told apart and left unsaid. + [speculating] turns recovery off inside a trial, whose refusal is an + answer the caller acts on; [guard_next] turns it off for the one next + [check], whose own refusal a caller re-words. *) + mutable recovering : bool; + mutable recovered : Loc.diag list; + mutable poison : int; + mutable speculating : int; + mutable guard_next : bool; } let new_env () = { @@ -240,11 +335,32 @@ let new_env () = { subst = []; tvpreds = []; chain = []; + refused_generics = Hashtbl.create 4; + gstructs = Hashtbl.create 4; + copies = Hashtbl.create 8; + broken = Hashtbl.create 2; + deferred = None; + glens = Hashtbl.create 8; + lenvars = []; + len_placeholder = false; + schain = []; in_field = false; classes = Hashtbl.create 8; tracks = Hashtbl.create 16; + recovering = false; + recovered = []; + poison = 0; + speculating = 0; + guard_next = false; } +(* A refusal [collect] can go on past: kept while a whole-file check is + collecting, in the order found, and raised otherwise. *) +let defer_or_raise env (d : Loc.diag) = + match env.deferred with + | Some l -> env.deferred <- Some (d :: l) + | None -> Loc.raise_diag d + (* Where a named type was declared, and what it has, as a note. This is the second half of the two-place messages: a refusal that says @@ -255,6 +371,13 @@ let new_env () = { the name is not one this environment placed, so it degrades to the message alone rather than to a wrong pointer. *) let declared_note env name = + (* A generic struct's copy is declared where its template is, and is + spoken of by the template's name there. *) + let shown = + match Hashtbl.find_opt struct_apps name with + | Some (g, _) when Hashtbl.mem env.copies name -> g + | _ -> name + in match Hashtbl.find_opt env.locs name with | None -> [] | Some at -> @@ -270,8 +393,8 @@ let declared_note env name = | None -> []) in let what = - if names = [] then name ^ " is declared here" - else name ^ " is declared here, with " ^ String.concat ", " names + if names = [] then shown ^ " is declared here" + else shown ^ " is declared here, with " ^ String.concat ", " names in [ Loc.note at what ] @@ -873,18 +996,24 @@ let no_such_rand name = Odin's [where] clause is the same shape ([core/slice/slice.odin:289] is [where intrinsics.type_is_ordered(T)]) with forty-one predicates against - these five. There is no [copyable?] any more and no Odin counterpart + these six. There is no [copyable?] any more and no Odin counterpart either: Odin has no move semantics, and since the repeal neither does this language, so [$T] never has to answer the question. - [integer?] is the narrowest of the five and exists because [numeric?] was + [integer?] is the narrowest numeric bound and exists because [numeric?] was one type too wide for a family of bodies: an integer body under [numeric?] is instantiated at f32 and f64 too, and (if (< x 0) (- 0 x) x) at -0.0 is the wrong abs while %, the bitwise operators and the shifts have no float meaning at all. A function that can be generalized should not need a variant per numeric type, and [integer?] is what lets the integer-only - ones say exactly what they need. *) -let predicate_names = [ "ordered?"; "equal?"; "hashable?"; "numeric?"; "integer?" ] + ones say exactly what they need. + + [enum?] admits exactly the enums. It entails [ordered?] and [equal?] and + not [numeric?]: an enum compares, and it converts to a number, but it is + not one — no arithmetic, no literal. It is what licenses the generic + enum-to-number conversion, beside [numeric?]. *) +let predicate_names = + [ "ordered?"; "equal?"; "hashable?"; "numeric?"; "integer?"; "enum?" ] (* ── What a type owns, transitively ──────────────────────────────────── The one structural ownership question that survived the repeal, because it @@ -1023,6 +1152,7 @@ let pred_holds p (t : Types.t) = | "hashable?" -> Types.keyable t | "numeric?" -> Types.is_numeric t | "integer?" -> Types.is_integer t + | "enum?" -> (match t with Types.Enum _ -> true | _ -> false) | _ -> false (* What one declared predicate *also* gives you. These are entailments over @@ -1035,8 +1165,8 @@ let pred_holds p (t : Types.t) = let pred_entails ~declared ~wanted = String.equal declared wanted || match wanted, declared with - | "ordered?", ("numeric?" | "integer?") -> true - | "equal?", ("numeric?" | "ordered?" | "integer?") -> true + | "ordered?", ("numeric?" | "integer?" | "enum?") -> true + | "equal?", ("numeric?" | "ordered?" | "integer?" | "enum?") -> true (* Every integer type is a number, so [integer?] gives a body everything [numeric?] does — the arithmetic, the written 0, the untyped integer literal — on top of the operations only it admits. The reverse is @@ -1127,12 +1257,19 @@ let fn_sig (t : Types.t) = let callable_ty t = fn_sig t <> None +(* A (CFn ...) is not on the list: it is one code address, and every call + through one tests for null and signals NullCall (see [Emit.null_check]), so + a zeroed one is an empty slot rather than a crash. That is what lets a table + of function pointers be a struct or a fixed array. An (Fn ...) stays + refused: a call through one is not tested, and (Option (Fn ...)) is the + field that holds one. *) let rec no_zeroed_fn loc what (t : Types.t) = match t with - | Types.Fn _ | Types.CFn _ -> + | Types.Fn _ -> fail loc "%s cannot be %s — it would be zeroed, and a zeroed function value is a \ - null pointer. Pass it as a parameter, or hold it in a let" + null pointer. Pass it as a parameter, hold it in a let, or store a \ + (CFn ...) if it captures nothing" what (Types.to_string t) | Types.Array (_, e) -> no_zeroed_fn loc what e | _ -> () @@ -1195,6 +1332,119 @@ let rec unfillable env seen (t : Types.t) : Types.t option = | None -> Some t) | _ -> Some t +(* How a concrete type is spelled inside an instantiation's name. The prelude + already writes this by hand — [filter-i32], [sum-f32], [append-i64] — so a + generated name reads like the handwritten one it replaces, which is what a + backtrace, a [Reach] edge and a dev-build cell all end up showing. + [Types.to_string] cannot serve: [[i32]] and [(Vec i32)] are not symbols. *) +let rec mangle_ty (t : Types.t) = + match t with + | Types.Unit -> "unit" + | Types.Slice (Types.Mut, e) -> "slice-" ^ mangle_ty e + | Types.Slice (Types.Const, e) -> "cslice-" ^ mangle_ty e + | Types.Array (n, e) -> Printf.sprintf "arr%Ld-%s" n (mangle_ty e) + | Types.Map (k, v) -> Printf.sprintf "map-%s-%s" (mangle_ty k) (mangle_ty v) + | Types.Ptr (Types.Mut, e) -> "ptr-" ^ mangle_ty e + | Types.Ptr (Types.Const, e) -> "cptr-" ^ mangle_ty e + | Types.Vec e -> "vec-" ^ mangle_ty e + | Types.Option e -> "opt-" ^ mangle_ty e + | Types.Fn (ps, r) -> + Printf.sprintf "fn-%s-to-%s" + (String.concat "-" (List.map mangle_ty ps)) (mangle_ty r) + | Types.CFn (ps, r) -> + Printf.sprintf "cfn-%s-to-%s" + (String.concat "-" (List.map mangle_ty ps)) (mangle_ty r) + (* Bare, because [Types.to_string] spells a variable with its [$] for the + reader and a symbol has no room for one. *) + | Types.Var n -> n + (* The key, not [Types.to_string]'s [(Small 8 i32)], which is a reader's + spelling and not a symbol. *) + | Types.Named n -> n + | t -> Types.to_string t + +let rec occurs_in ~needle (t : Types.t) = + Types.equal needle t + || + match t with + | Types.Slice (_, e) | Types.Array (_, e) | Types.Ptr (_, e) | Types.Vec e + | Types.Option e -> occurs_in ~needle e + | Types.Map (k, v) -> occurs_in ~needle k || occurs_in ~needle v + | Types.Fn (ps, r) | Types.CFn (ps, r) -> + List.exists (occurs_in ~needle) ps || occurs_in ~needle r + | Types.LArray (_, e) -> occurs_in ~needle e + (* Through a struct copy's arguments, or [(Node (Node $t))] would not be + seen to contain [(Node $t)]. *) + | Types.Named k -> + (match Hashtbl.find_opt struct_apps k with + | Some (_, args) -> List.exists (occurs_in ~needle) args + | None -> false) + | _ -> false + +(* [b] is [a] with something built around it: same shape, strictly bigger. *) +let grows ~from_:a ~to_:b = + List.length a = List.length b + && List.for_all2 (fun x y -> occurs_in ~needle:x y) a b + && not (List.for_all2 Types.equal a b) + +(* A generic struct's copy at [args], by key: [Small-8-i32], or + [Small-$n-$t] at variables. Recorded in [struct_apps] and [Types.display] + as the key is made; the copy's fields are [struct_copy]'s business. *) +let struct_app g args = + let key = + g ^ "-" + ^ String.concat "-" + (List.map + (function + | Types.Var v -> "$" ^ v + | Types.Len n -> Int64.to_string n + | t -> mangle_ty t) + args) + in + if not (Hashtbl.mem struct_apps key) then begin + Hashtbl.replace struct_apps key (g, args); + Hashtbl.replace Types.display key + (Printf.sprintf "(%s %s)" g + (String.concat " " (List.map Types.to_string args))) + end; + key + +(* Does [name] contain itself by value? [check_finite] asks it of every + declared type once they are all collected, and a generic struct's copy asks + it of itself when it is made, which is after that. *) +let finite_from env name0 = + let rec walk seen name = + if List.mem name seen then + (let shown = Types.to_string (Types.Named name) in + fail (Option.value (Hashtbl.find_opt env.locs name) ~default:Loc.unknown) + "%s contains itself by value, so it has no size — go through (Ptr %s)" + shown shown); + let seen = name :: seen in + match Hashtbl.find_opt env.structs name with + | Some s -> List.iter (fun (f : Tast.field) -> ty seen f.Tast.fty) s.Tast.fields + | None -> + match Hashtbl.find_opt env.datas name with + | Some u -> + List.iter + (fun (c : Tast.variant) -> + List.iter (fun (f : Tast.field) -> ty seen f.Tast.fty) c.Tast.vfields) + u.Tast.cases + | None -> + (* A union whose member is itself is the same infinite type a struct's + is — the size is the largest member and the largest member is the + whole thing. Nothing about overlaying storage makes the recursion + finite, so it is on the same walk rather than left to hang the + layout calculator. *) + match Hashtbl.find_opt env.unions name with + | None -> () + | Some u -> + List.iter (fun (f : Tast.field) -> ty seen f.Tast.fty) u.Tast.fields + and ty seen = function + | Types.Named n -> walk seen n + | Types.Array (_, e) | Types.Option e -> ty seen e + | _ -> () + in + walk [] name0 + (* The name under the sigil. [$t] is how a defn signature introduces a type variable and [t] is how the body spells the same one, so the tables that record which variables are in scope — [env.tyvars] and [env.subst] — are @@ -1227,7 +1477,17 @@ let rec resolve env ?(seen = []) (t : Ast.texpr) : Types.t = | Ast.Tarray (l, e) -> let e = resolve env ~seen e in no_zeroed_fn loc "a fixed array's element" e; - Types.Array (array_len env loc l, e) + (match l with + | Ast.Lname n + when (not env.len_placeholder) + && List.mem (tyvar_bare n) env.lenvars + && not (List.mem_assoc (tyvar_bare n) env.subst) -> + Types.LArray (tyvar_bare n, e) + | _ -> Types.Array (array_len env loc l, e)) + | Ast.Tlen n -> + fail loc + "%Ld is not a type. An integer stands only where a generic struct takes \ + a length, as in (Small 8 i32)" n (* {K V} is the type spelling. There is no map *literal*: a bare map form in expression position is a struct literal's field list, and giving the same braces two meanings is what the colon-to-dot change was for. A map is @@ -1291,15 +1551,10 @@ let rec resolve env ?(seen = []) (t : Ast.texpr) : Types.t = (resolve env ~seen v) | "Map", _ -> fail loc "(Map K V) takes exactly two types" | "Result", _ -> unimplemented loc "(Result T E)" 6 + | _ when Hashtbl.mem env.gstructs name -> apply_struct env ~seen loc name args | _ -> - (* Not generics, which are here: a *function* is generic over [$t] and - instantiated per call site. This is a parameterised named type — - [(Pair i32 f64)] — and that is a different thing and is not built. - [Types.Named] is a bare string with no parameters, so there is - nowhere to put the arguments, and giving it some is a change to - [Types.t] and therefore to the layout calculator, both backends, - [Render] and the DWARF path. docs/SPIKE-GENERICS.md, question 4, - prices it and leaves it out. *) + (* No type of this name takes arguments: a generic struct is caught + by the arm above, and [Ptr], [Option], [Vec] and [Map] further up. *) (* A head that is not a type at all but one edit from one is the typo [(Vect i32)], and the generics sentence would answer a question nobody asked. *) @@ -1316,9 +1571,169 @@ let rec resolve env ?(seen = []) (t : Ast.texpr) : Types.t = "unknown type %s — did you mean %s?" name m | _ -> ()); fail loc - "%s takes no type arguments. A generic function is written with $t \ - in its parameter vector; a generic type is not there yet" - name) + "%s takes no type arguments. A generic struct is one whose fields \ + introduce $t, as in (defstruct %s [x $t]), and a generic function \ + one whose parameter vector does" + name name) + +(* [(Small 8 i32)]: each argument read as the parameter it stands for — a + length or a type — and the copy made, or found. *) +and apply_struct env ~seen loc name args = + let g = Hashtbl.find env.gstructs name in + let spelled = + Printf.sprintf "(%s %s)" name + (String.concat " " (List.map (fun (p, _) -> "$" ^ p) g.gparams)) + in + let n = List.length g.gparams in + if List.length args <> n then + Loc.failk "check/generic-struct-arity" loc + ~notes:[ Loc.note g.gloc (name ^ " is declared here") ] + "%s takes %d argument%s, %s, and this gives %d" + name n (if n = 1 then "" else "s") spelled (List.length args); + let targs = + List.map2 + (fun (p, is_len) (a : Ast.texpr) -> + if is_len then struct_len_arg env name p a + else + match a.Ast.t with + | Ast.Tlen k -> + fail a.Ast.tloc + "%s's $%s is a type, and %Ld is a length — %s" name p k spelled + | _ -> resolve env ~seen a) + g.gparams args + in + Types.Named (struct_copy env loc name targs) + +and struct_len_arg env name p (a : Ast.texpr) = + let not_one what = + fail a.Ast.tloc + "%s's $%s is a length: an integer, a constant's name or a length \ + variable, and %s is %s" name p (Cimport.ty_source a) what + in + match a.Ast.t with + | Ast.Tlen k when Int64.compare k 0L < 0 -> + fail a.Ast.tloc "%s's $%s is a length, and %Ld is negative" name p k + | Ast.Tlen k -> Types.Len k + | Ast.Tname n -> + let bare = tyvar_bare n in + (match List.assoc_opt bare env.subst with + | Some (Types.Len _ as l) -> l + | Some (Types.Var v) -> Types.Var v + | Some t -> not_one ("the type " ^ Types.to_string t) + | None -> + if List.mem bare env.lenvars then Types.Var bare + else if List.mem bare env.tyvars then not_one "a type variable" + else + match Hashtbl.find_opt env.consts n with + | Some k -> Types.Len k + | None -> not_one "none of them") + | _ -> not_one "a type" + +(* The copy of generic struct [name] at [targs], made on first use and + registered as an ordinary struct under its key. *) +and struct_copy ?(at_definition = false) env loc name targs = + let key = struct_app name targs in + if Hashtbl.mem env.copies key then key + else if Hashtbl.mem env.broken name then begin + Hashtbl.replace env.copies key (List.exists generic_arg targs); + Hashtbl.replace env.structs key { Tast.sname = key; fields = [] }; + key + end + else begin + if Hashtbl.mem env.structs key || Hashtbl.mem env.datas key + || Hashtbl.mem env.unions key then + fail loc + "%s at these arguments is called %s, and %s is already defined — \ + rename one" name key key; + let g = Hashtbl.find env.gstructs name in + (* A copy that asks for a copy of its own template at a type built around + its own arguments — [(defstruct Grow [next (Ptr (Grow [$t]))])] — asks + forever, and pointers do not stop it: each copy is made the moment it + is named. *) + let chain_text () = + String.concat "\n " + (List.map + (fun (h, a) -> + Printf.sprintf "(%s %s)" h + (String.concat " " (List.map Types.to_string a))) + (env.schain @ [ (name, targs) ])) + in + if List.exists + (fun (h, a) -> String.equal h name && grows ~from_:a ~to_:targs) + env.schain + || List.length env.schain >= 64 then + Loc.failk "check/runaway-instantiation" loc + ~notes:[ Loc.note g.gloc (name ^ " is declared here") ] + "%s names a copy of itself at a type built around its own \ + arguments, and that copy names another, without end:\n %s\n\ + Name the same arguments, or smaller ones" name (chain_text ()); + let generic = List.exists generic_arg targs in + (* In before its fields, so a field that names the same copy through a + pointer — [(defstruct Node [next (Ptr (Node $t))])] — finds it. *) + Hashtbl.replace env.copies key generic; + Hashtbl.replace env.structs key { Tast.sname = key; fields = [] }; + Hashtbl.replace env.locs key g.gloc; + let saved = + (env.subst, env.tyvars, env.lenvars, env.tvpreds, env.len_placeholder, + env.in_field, env.schain) + in + let restore () = + let s, t, l, p, lp, f, c = saved in + env.subst <- s; env.tyvars <- t; env.lenvars <- l; env.tvpreds <- p; + env.len_placeholder <- lp; env.in_field <- f; env.schain <- c + in + env.subst <- List.map2 (fun (p, _) a -> (p, a)) g.gparams targs; + env.tyvars <- []; + env.lenvars <- []; + env.tvpreds <- []; + env.len_placeholder <- generic; + env.in_field <- true; + env.schain <- env.schain @ [ (name, targs) ]; + match + List.map + (fun (f : Ast.field) -> + let fty = resolve env f.Ast.fty in + no_zeroed_fn f.Ast.fty.Ast.tloc + (Printf.sprintf "the field %s" f.Ast.fname) fty; + { Tast.fname = f.Ast.fname; fty }) + g.gfields + with + | fields -> + restore (); + Hashtbl.replace env.structs key { Tast.sname = key; fields }; + finite_from env key; + key + | exception e -> + restore (); + Hashtbl.remove env.copies key; + Hashtbl.remove env.structs key; + (* A field refused inside the template says nothing about which use + asked for this copy; the note names it, one per level of copies. *) + (match e with + | Loc.Error d when d.Loc.dloc <> loc && not at_definition -> + Loc.raise_diag + { d with + Loc.notes = + d.Loc.notes + @ [ Loc.note loc + (Types.to_string (Types.Named key) ^ " is made here") ] } + | e -> raise e) + end + +(* Does a struct argument still mention a variable? *) +and generic_arg (t : Types.t) = + match t with + | Types.Var _ | Types.LArray _ -> true + | Types.Slice (_, e) | Types.Array (_, e) | Types.Ptr (_, e) | Types.Vec e + | Types.Option e -> generic_arg e + | Types.Map (k, v) -> generic_arg k || generic_arg v + | Types.Fn (ps, r) | Types.CFn (ps, r) -> + List.exists generic_arg ps || generic_arg r + | Types.Named k -> + (match Hashtbl.find_opt struct_apps k with + | Some (_, a) -> List.exists generic_arg a + | None -> false) + | _ -> false (* One edit away from a type that exists — a substitution, an insertion, a deletion or a transposition of neighbours. Bounded at one, because two edits @@ -1352,12 +1767,19 @@ and resolve_name env ~seen loc n = one, a mistyped type name silently became a type parameter and made the function more permissive than it was written to be. *) let bare = tyvar_bare n in + let a_length () = + fail loc + "%s is a length, not a type — it stands where an array's length does, \ + as in [%s T], or as a generic struct's length argument" n n + in match List.assoc_opt bare env.subst with + | Some (Types.Len _) -> a_length () (* Inside an instantiation: the variable is this concrete type, and every node checked under it is as concrete as if it had been written out. *) | Some t -> t | None -> - if List.mem bare env.tyvars then Types.Var bare + if List.mem bare env.lenvars then a_length () + else if List.mem bare env.tyvars then Types.Var bare else if n <> bare then (* A sigil on a name nothing binds. Two different mistakes wear the same spelling, and which one it is turns on whether any variable is in scope @@ -1376,17 +1798,17 @@ and resolve_name env ~seen loc n = (match (match env.tyvars with [] -> List.map fst env.subst | vs -> vs) with | [] -> Loc.failk "check/unbound-type-variable" loc - "%s introduces a type variable, and only a defn signature can — write \ - the concrete type here" n + "%s introduces a type variable, and only a defn signature or a \ + defstruct's fields can — write the concrete type here" n | [ v ] -> Loc.failk "check/unbound-type-variable" loc "nothing binds the type variable %s — this signature introduces %s, \ - so write %s here, or a concrete type" n v v + so write %s here, or a concrete type" n ("$" ^ v) ("$" ^ v) | vars -> Loc.failk "check/unbound-type-variable" loc "nothing binds the type variable %s — this signature introduces %s, \ so write one of those here, or a concrete type" - n (String.concat " and " vars)) + n (String.concat " and " (List.map (fun v -> "$" ^ v) vars))) else match Types.ikind_of_name n with | Some k -> Types.Int k @@ -1416,6 +1838,21 @@ and resolve_name env ~seen loc n = if List.mem n seen then fail loc "the type alias %s is defined in terms of itself" n else resolve env ~seen:(n :: seen) (Hashtbl.find env.aliases n) + | _ when Hashtbl.mem env.gstructs n -> + let g = Hashtbl.find env.gstructs n in + Loc.failk "check/generic-struct-arity" loc + ~notes:[ Loc.note g.gloc (n ^ " is declared here") ] + "%s is generic, and a type only once it is given its arguments: \ + write (%s %s)" n n + (* Variables are only an answer where a signature binds them; in + ordinary code the example is concrete. *) + (String.concat " " + (List.map + (fun (p, is_len) -> + if env.tyvars <> [] then "$" ^ p + else if is_len then "8" + else "i32") + g.gparams)) | _ when Hashtbl.mem env.structs n -> Types.Named n (* A data type is [Named] exactly as a struct is: one case in [Types.t] covers both, and which table the name is in is what tells them apart. @@ -1453,18 +1890,16 @@ and resolve_name env ~seen loc n = permissive than it was written to be. *) | _ when n <> "" && n.[0] = Char.lowercase_ascii n.[0] -> (* The parameter-vector suggestion is only followable where a - parameter vector exists. A field has none and never will — only a - defn signature binds a variable, and a field is built at one type - for every value — so at a field the message offers the two things - that can actually be written there. *) + parameter vector exists. A field has none: a defstruct's field + introduces the variable where it stands, so at a field the message + says that instead. *) if env.in_field then Loc.failk "check/unknown-type" loc - "unknown type %s. A lowercase name is a type variable, and a \ - field cannot hold one: only a defn signature introduces type \ - variables, and a field is built at one type for every value — \ - generic types are not there. Write a concrete type here, or dyn \ - to hold any value" - n + "unknown type %s. A lowercase name is a type variable only where \ + it is introduced with $%s, and in a defstruct's fields that makes \ + the struct generic over it. Write $%s, a concrete type, or dyn to \ + hold any value" + n n n else Loc.failk "check/unknown-type" loc "unknown type %s. A lowercase name is a type variable only where a \ @@ -1476,7 +1911,19 @@ and resolve_name env ~seen loc n = and array_len env loc = function | Ast.Lint n -> n | Ast.Lname n -> - (match Hashtbl.find_opt env.consts n with + let bare = tyvar_bare n in + (match List.assoc_opt bare env.subst with + | Some (Types.Len k) -> k + | Some (Types.Var _) -> abstract_len + | Some t -> + fail loc "%s is the type %s here, and an array length is an integer, a \ + constant or a length variable" n (Types.to_string t) + | None when List.mem bare env.lenvars -> abstract_len + | None when List.mem bare env.tyvars -> + fail loc "%s is a type variable, and an array length is an integer, a \ + constant or a length variable" n + | None -> + match Hashtbl.find_opt env.consts n with | Some v -> v | None -> fail loc "%s is not a compile-time integer constant, so it cannot be \ @@ -1507,6 +1954,7 @@ let is_type_name env n = || List.mem n [ "bool"; "string"; "dyn"; "Unit"; "Never"; "Allocator" ] || Hashtbl.mem env.aliases n || Hashtbl.mem env.structs n + || Hashtbl.mem env.gstructs n || Hashtbl.mem env.datas n || Hashtbl.mem env.unions n || Hashtbl.mem env.enums n @@ -1617,9 +2065,37 @@ let dyn_param_or_typo env n loc = parameters are lowercase" n -let pair_params ?(also = fun _ -> false) env (items : Ast.pitem list) - : Ast.field list = - let is_type_name env n = is_type_name env n || also n in +(* The pairings a parameter vector owes to a type the program declares under + a name that is also a legal parameter name — a lowercase one, since a + capitalised name is refused as a parameter. [(defn f [p point] ...)] is one + parameter while [point] is a type and two dyn ones the moment it is not, + so adding or removing the type re-pairs the signature with no edit to it. + The type still wins; this is the warning at the parameter, filled by + [pair_decls] and printed by [build_program] with the other warnings. *) +let pairing_warnings : Loc.diag list ref = ref [] + +let pair_params ?(also = fun _ -> false) ?(declared = fun _ -> None) + ?(hide = fun _ -> false) env (items : Ast.pitem list) : Ast.field list = + let is_type_name env n = (is_type_name env n && not (hide n)) || also n in + let warn_pairing n t tloc = + let bare = + match String.rindex_opt t '/' with + | Some i -> String.sub t (i + 1) (String.length t - i - 1) + | None -> t + in + match declared t with + | Some (what, (at : Loc.t)) + when bare <> "" && bare.[0] >= 'a' && bare.[0] <= 'z' -> + pairing_warnings := + Loc.diag ~kind:"check/parameter-reads-a-type" tloc + (Printf.sprintf + "[%s %s] is one parameter %s of type %s, the %s declared at %s, \ + and not two dyn parameters. If two were meant, give the second \ + a name no type has" + n t n t what (Loc.to_string at)) + :: !pairing_warnings + | _ -> () + in let dyn loc = { Ast.t = Ast.Tname "dyn"; tloc = loc } in let rec go = function | [] -> [] @@ -1635,6 +2111,7 @@ let pair_params ?(also = fun _ -> false) env (items : Ast.pitem list) | Ast.Pname (n, loc) :: Ast.Ptype t :: rest -> { Ast.fname = n; fty = t; floc = loc } :: go rest | Ast.Pname (n, loc) :: Ast.Pname (t, tloc) :: rest when is_type_name env t -> + warn_pairing n t tloc; { Ast.fname = n; fty = { Ast.t = Ast.Tname t; tloc }; floc = loc } :: go rest (* The slot after this one is not a type, so this one is a parameter with no type written — unless the slot after it only *looks* unlike a type @@ -1764,13 +2241,42 @@ let pair_decls env (decls : Ast.decl list) : Ast.decl list = match d.Ast.d with Ast.Defclass (n, _) -> Some n | _ -> None) decls in - let fn (f : Ast.fn) = + (* The types the program declares, with what kind and where, for + [pair_params]'s warning. The prelude's are left out: its names are the + language's, not a declaration the reader made. *) + let types = Hashtbl.create 16 in + List.iter + (fun (d : Ast.decl) -> + let add n what = + if d.Ast.dloc.Loc.file <> Prelude.file + && not (List.mem n Types.primitive_names) then + Hashtbl.replace types n (what, d.Ast.dloc) + in + match d.Ast.d with + | Ast.Defstruct (n, _, _) -> add n "struct" + | Ast.Defenum (n, _) -> add n "enum" + | Ast.Defalias (n, _) -> add n "alias" + | Ast.Defdata (n, _) -> add n "data type" + | Ast.Defunion (n, _) -> add n "union" + | _ -> ()) + decls; + pairing_warnings := []; + (* A prelude signature is paired against the prelude's types alone: a + program's type named [t] must not turn the prelude's parameter [t] into + a type. *) + let fn ~prelude (f : Ast.fn) = match f.Ast.praw with | None -> f - | Some items -> { f with Ast.params = pair_params env items; praw = None } + | Some items -> + let hide n = prelude && Hashtbl.mem types n in + { f with + Ast.params = + pair_params ~hide ~declared:(Hashtbl.find_opt types) env items; + praw = None } in List.map (fun (d : Ast.decl) -> + let prelude = String.equal d.Ast.dloc.Loc.file Prelude.file in match d.Ast.d with (* A class's slot vector is paired here and nowhere earlier, for the reason a [defn]'s is, and its constructor is written from the @@ -1784,9 +2290,9 @@ let pair_decls env (decls : Ast.decl list) : Ast.decl list = (f.Ast.fname, slot_of env ~classes n f.Ast.fname f.Ast.fty)) slots); Classes.constructor n slots d.Ast.dloc - | Ast.Defn f -> { d with Ast.d = Ast.Defn (fn f) } - | Ast.Declare (f, c) -> { d with Ast.d = Ast.Declare (fn f, c) } - | Ast.DeclareC (f, c) -> { d with Ast.d = Ast.DeclareC (fn f, c) } + | Ast.Defn f -> { d with Ast.d = Ast.Defn (fn ~prelude f) } + | Ast.Declare (f, c) -> { d with Ast.d = Ast.Declare (fn ~prelude f, c) } + | Ast.DeclareC (f, c) -> { d with Ast.d = Ast.DeclareC (fn ~prelude f, c) } | _ -> d) decls @@ -1821,6 +2327,7 @@ let defvar_reads_as_type env (t : Ast.texpr) = | Ast.Tname n -> is_type_name env n | Ast.Tapp (head, _) -> List.mem head [ "Ptr"; "Option"; "Vec"; "Map"; "Result" ] + || Hashtbl.mem env.gstructs head (* A slice, a fixed array, a map type or an (Fn ...): [Parse] only carries one of these over when it read as a type and had no value reading, so there is nothing here to decide. *) @@ -1997,9 +2504,9 @@ let settle_defvars env (decls : Ast.decl list) : Ast.decl list = (* The variables a signature introduces: every [$t] written in it, in the order written, once each. Only a [defn] signature is scanned, which is what makes the binding site a *place* and not merely a spelling. *) -let signature_tyvars (fn : Ast.fn) = +let sigil_vars ~kinds_of (ts : Ast.texpr list) = let acc = ref [] in - let name loc n = + let add loc n is_len = if n <> "" && n.[0] = '$' then begin let bare = String.sub n 1 (String.length n - 1) in if bare = "" then fail loc "$ on its own does not name a type variable"; @@ -2009,24 +2516,59 @@ let signature_tyvars (fn : Ast.fn) = || Types.ikind_of_name bare <> None || Types.fkind_of_name bare <> None then fail loc "%s is a type, so $%s cannot be a type variable" bare bare; - if not (List.mem bare !acc) then acc := bare :: !acc + match List.assoc_opt bare !acc with + | None -> acc := (bare, is_len) :: !acc + | Some k when k = is_len -> () + | Some _ -> + fail loc + "$%s stands for a length in one place here and a type in another — \ + a length goes in an array's length slot, [$%s T], and a type \ + everywhere else. Give the two different names" bare bare end in let rec ty (t : Ast.texpr) = match t.Ast.t with - | Ast.Tname n -> name t.Ast.tloc n + | Ast.Tname n -> add t.Ast.tloc n false | Ast.Tslice (_, e) -> ty e + | Ast.Tarray (Ast.Lname n, e) -> add t.Ast.tloc n true; ty e | Ast.Tarray (_, e) -> ty e | Ast.Tmap (k, v) -> ty k; ty v - (* The head of an application is a constructor — [Ptr], [Option], [Vec] — - and a variable cannot stand there: this spike is generic over types, - not over type constructors. A [$t] inside the arguments is ordinary. *) - | Ast.Tapp (_, args) -> List.iter ty args + (* The head of an application is a constructor — [Ptr], [Option], [Vec], + a generic struct — and a variable cannot stand there: this is generic + over types, not over type constructors. A [$t] inside the arguments is + ordinary, and a generic struct's length argument is a length. *) + | Ast.Tapp (h, args) -> + (match kinds_of h with + | Some ks when List.length ks = List.length args -> + List.iter2 + (fun is_len (a : Ast.texpr) -> + match a.Ast.t with + | Ast.Tname n when is_len -> add a.Ast.tloc n true + | _ -> ty a) + ks args + | _ -> List.iter ty args) | Ast.Tfn (_, ps, r) -> List.iter ty ps; ty r + | Ast.Tlen _ -> () in - List.iter (fun (p : Ast.field) -> ty p.Ast.fty) fn.Ast.params; - (match fn.Ast.ret with Some r -> ty r | None -> ()); - List.rev !acc + List.iter ty ts; + let vs = List.rev !acc in + (List.map fst vs, List.filter_map (fun (v, l) -> if l then Some v else None) vs, + vs) + +let struct_kinds env h = + Option.map (fun g -> List.map snd g.gparams) (Hashtbl.find_opt env.gstructs h) + +(* The variables a signature introduces: every [$t] written in it, in the + order written, once each, and which of them are lengths. Only a [defn] + signature and a [defstruct]'s fields are scanned, which is what makes the + binding site a *place* and not merely a spelling. *) +let signature_tyvars env (fn : Ast.fn) = + let vars, lens, _ = + sigil_vars ~kinds_of:(struct_kinds env) + (List.map (fun (p : Ast.field) -> p.Ast.fty) fn.Ast.params + @ Option.to_list fn.Ast.ret) + in + vars, lens (* Bind the variables in a parameter's written type from the type an argument turned out to have. Odin's [is_polymorphic_type_assignable], structurally @@ -2095,6 +2637,17 @@ let rec bind_ty ?(widen = false) ?(ro = true) subst (pat : Types.t) | Types.Fn (ps, r), Types.CFn (ps', r') when widen -> List.length ps = List.length ps' && List.for_all2 inner ps ps' && inner r r' + (* A length variable's array against a concrete one: the length is bound + the way a type variable is, to a [Types.Len]. *) + | Types.LArray (v, p), Types.Array (n, a) -> + bind_ty ~ro:false subst (Types.Var v) (Types.Len n) && inner p a + (* A struct copy at variables against a copy of the same template: each + argument against its own. *) + | Types.Named p, Types.Named a -> + (match Hashtbl.find_opt struct_apps p, Hashtbl.find_opt struct_apps a with + | Some (g, ps), Some (h, as_) when String.equal g h -> + List.length ps = List.length as_ && List.for_all2 inner ps as_ + | _ -> Types.fits ~expected:pat ~actual:arg) (* Nothing generic left on the pattern side: this is ordinary type equality, and [Never] fits anywhere exactly as it does elsewhere. *) | p, a -> Types.fits ~expected:p ~actual:a @@ -2111,12 +2664,29 @@ let rec subst_ty subst (t : Types.t) = | Types.Fn (ps, r) -> Types.Fn (List.map (subst_ty subst) ps, subst_ty subst r) | Types.CFn (ps, r) -> Types.CFn (List.map (subst_ty subst) ps, subst_ty subst r) + | Types.LArray (v, e) -> + (match List.assoc_opt v subst with + | Some (Types.Len n) -> Types.Array (n, subst_ty subst e) + | Some (Types.Var w) -> Types.LArray (w, subst_ty subst e) + | _ -> Types.LArray (v, subst_ty subst e)) + (* A struct copy at variables becomes the copy at what they are bound to. + Only its key is made here — there is no env to lay it out in — and + [realise] makes the copy itself before anything reads its fields. *) + | Types.Named k -> + (match Hashtbl.find_opt struct_apps k with + | Some (g, args) when List.exists open_ty args -> + let args = List.map (subst_ty subst) args in + Types.Named (struct_app g args) + | _ -> t) | t -> t -(* Does this resolved type still mention a variable? *) -let rec generic_ty (t : Types.t) = +(* Does this resolved type still mention a variable? Not through a struct + copy's arguments: an operator over a [(Pair $t)] is refused as one over a + struct, not as one over a type variable. [open_ty] is the question that + does look through, for binding and substituting. *) +and generic_ty (t : Types.t) = match t with - | Types.Var _ -> true + | Types.Var _ | Types.LArray _ -> true | Types.Slice (_, e) | Types.Array (_, e) | Types.Ptr (_, e) | Types.Vec e | Types.Option e -> generic_ty e | Types.Map (k, v) -> generic_ty k || generic_ty v @@ -2124,6 +2694,37 @@ let rec generic_ty (t : Types.t) = List.exists generic_ty ps || generic_ty r | _ -> false +and open_ty (t : Types.t) = + match t with + | Types.Var _ | Types.LArray _ -> true + | Types.Slice (_, e) | Types.Array (_, e) | Types.Ptr (_, e) | Types.Vec e + | Types.Option e -> open_ty e + | Types.Map (k, v) -> open_ty k || open_ty v + | Types.Fn (ps, r) | Types.CFn (ps, r) -> List.exists open_ty ps || open_ty r + | Types.Named k -> + (match Hashtbl.find_opt struct_apps k with + | Some (_, args) -> List.exists open_ty args + | None -> false) + | _ -> false + +(* Make every struct copy [t] names that [subst_ty] only named. A copy has + to exist in [env.structs] before a field of it is read, and [subst_ty] has + no env to make one in. *) +let rec realise env loc (t : Types.t) = + match t with + | Types.Slice (_, e) | Types.Array (_, e) | Types.Ptr (_, e) | Types.Vec e + | Types.Option e | Types.LArray (_, e) -> realise env loc e + | Types.Map (k, v) -> realise env loc k; realise env loc v + | Types.Fn (ps, r) | Types.CFn (ps, r) -> + List.iter (realise env loc) ps; realise env loc r + | Types.Named k when not (Hashtbl.mem env.structs k) -> + (match Hashtbl.find_opt struct_apps k with + | Some (g, args) when Hashtbl.mem env.gstructs g -> + List.iter (realise env loc) args; + ignore (struct_copy env loc g args) + | _ -> ()) + | _ -> () + (* Does a type a call site bound a variable to reach a [dyn] anywhere? See the refusal in [generic_call]: [dyn] is a concrete type and substitutes like any other, so nothing stopped a copy being made at it, and the copies walked @@ -2157,36 +2758,12 @@ let unconstrained env loc op ~needs (t : Types.t) = | _ -> Loc.failk "check/unconstrained-type-variable" loc "%s over the type variable %s: nothing declares %s %s. Write \ - {:where (%s $%s)} at the head of the body, or take the operation as \ + {:where (%s %s)} at the head of the body, or take the operation as \ a parameter, a (Fn [%s %s] ...), and call it here" op (Types.to_string t) (Types.to_string t) needs needs (Types.to_string t) (Types.to_string t) (Types.to_string t) -(* How a concrete type is spelled inside an instantiation's name. The prelude - already writes this by hand — [filter-i32], [sum-f32], [append-i64] — so a - generated name reads like the handwritten one it replaces, which is what a - backtrace, a [Reach] edge and a dev-build cell all end up showing. - [Types.to_string] cannot serve: [[i32]] and [(Vec i32)] are not symbols. *) -let rec mangle_ty (t : Types.t) = - match t with - | Types.Unit -> "unit" - | Types.Slice (Types.Mut, e) -> "slice-" ^ mangle_ty e - | Types.Slice (Types.Const, e) -> "cslice-" ^ mangle_ty e - | Types.Array (n, e) -> Printf.sprintf "arr%Ld-%s" n (mangle_ty e) - | Types.Map (k, v) -> Printf.sprintf "map-%s-%s" (mangle_ty k) (mangle_ty v) - | Types.Ptr (Types.Mut, e) -> "ptr-" ^ mangle_ty e - | Types.Ptr (Types.Const, e) -> "cptr-" ^ mangle_ty e - | Types.Vec e -> "vec-" ^ mangle_ty e - | Types.Option e -> "opt-" ^ mangle_ty e - | Types.Fn (ps, r) -> - Printf.sprintf "fn-%s-to-%s" - (String.concat "-" (List.map mangle_ty ps)) (mangle_ty r) - | Types.CFn (ps, r) -> - Printf.sprintf "cfn-%s-to-%s" - (String.concat "-" (List.map mangle_ty ps)) (mangle_ty r) - | t -> Types.to_string t - (* ── The runaway instantiation, refused by name rather than by depth ──── [(defn grow [x $t] () (grow [x x]))] asks for a copy at [[t]], which asks for one at [[[t]]], forever. Before this the checker did not fail, it @@ -2213,23 +2790,6 @@ let rec mangle_ty (t : Types.t) = is the whole design. The depth backstop below stays as a backstop only: it catches a growth this test does not recognise, and it is never the thing the message is about. *) -let rec occurs_in ~needle (t : Types.t) = - Types.equal needle t - || - match t with - | Types.Slice (_, e) | Types.Array (_, e) | Types.Ptr (_, e) | Types.Vec e - | Types.Option e -> occurs_in ~needle e - | Types.Map (k, v) -> occurs_in ~needle k || occurs_in ~needle v - | Types.Fn (ps, r) | Types.CFn (ps, r) -> - List.exists (occurs_in ~needle) ps || occurs_in ~needle r - | _ -> false - -(* [b] is [a] with something built around it: same shape, strictly bigger. *) -let grows ~from_:a ~to_:b = - List.length a = List.length b - && List.for_all2 (fun x y -> occurs_in ~needle:x y) a b - && not (List.for_all2 Types.equal a b) - let runaway env loc gname cparams = let chain_text () = String.concat "\n " @@ -2429,6 +2989,49 @@ and const_steps ro (ty : Types.t) n = let const_copy env (e : Types.t) = if owning env e || holds_dyn env e then None else Some "(clone v)" +(* Whether (clone x) accepts a value of this type — the same arms the clone + builtin takes: a Vec or a Map whose elements own nothing, or a slice whose + elements neither own storage nor hold a dyn. *) +let clone_accepts env (t : Types.t) = + match t with + | Types.Vec _ | Types.Map _ -> not (region_only env t) + | Types.Slice (_, e) -> not (owning env e || holds_dyn env e) + | _ -> false + +(* The end of clone's refusal for a container of owning elements. Pushing + the elements themselves into a second container would copy their headers + and share their blocks, so the advice is a copy of each element where + clone takes one, and otherwise that there is no copy to make. *) +let insert_copies env (t : Types.t) = + let elem = + match t with + | Types.Vec e | Types.Slice (_, e) | Types.Map (_, e) -> Some e + | _ -> None + in + match elem with + | Some e when clone_accepts env e -> + "Build a second container and push a (clone x) of each element into it" + | Some e -> + Printf.sprintf + "Nothing copies what a %s owns either, so read the elements where they \ + are" + (Types.to_string e) + | None -> "Build a second container and insert into it" + +(* A call written back out as source, for a fix that has to repeat what the + reader wrote: names, integers and calls of those. Anything else is [None] + and the caller says the fix in words. *) +let rec spell_form (a : Ast.expr) = + match a.Ast.e with + | Ast.Var v -> Some v + | Ast.Int n -> Some (Int64.to_string n) + | Ast.UInt (_, s) -> Some s + | Ast.Call (f, args) -> + let parts = List.map spell_form (f :: args) in + if List.mem None parts then None + else Some ("(" ^ String.concat " " (List.filter_map Fun.id parts) ^ ")") + | _ -> None + (* A store through a read-only view: a [[const T]] or a (Ptr const T). *) let refuse_const_place env loc (view : Types.t) = match view with @@ -3032,7 +3635,8 @@ let box loc (e : Tast.expr) : Tast.expr = caller that starts doing that gets a sentence instead of a silent mis-lowering. *) | Types.Named _ | Types.Enum _ | Types.Option _ | Types.Ptr _ - | Types.Alloc | Types.Fn _ | Types.CFn _ | Types.Var _ -> + | Types.Alloc | Types.Fn _ | Types.CFn _ | Types.Var _ | Types.Len _ + | Types.LArray _ -> no_dyn_yet loc ~into:true e.Tast.ty "" let unbox loc (want : Types.t) (e : Tast.expr) : Tast.expr = @@ -3527,6 +4131,63 @@ let hash_ty = Types.Int Types.U64 Each caller calls it again rather than sharing one value: [slots] and [slot_tys] are counted up per frame, and two frames that shared a context would share a slot counter. *) +(* What a refused subexpression stands as while recovering. [Zero] of [Never] + is a value nothing else builds, so it is recognisable; see [check]. *) +let poison loc = { Tast.e = Tast.Zero Types.Never; ty = Types.Never; loc } + +(* A poison, or a read of a local one was bound to. *) +let is_poison (r : Tast.expr) = + Types.equal r.Tast.ty Types.Never + && (match r.Tast.e with Tast.Zero Types.Never | Tast.Local _ -> true | _ -> false) + +let record_recovered env (d : Loc.diag) = + let same (x : Loc.diag) = x.Loc.dloc = d.Loc.dloc && String.equal x.Loc.dmsg d.Loc.dmsg in + if not (List.exists same env.recovered) then env.recovered <- d :: env.recovered + +(* [f] with recovery off, for a check whose refusal is an answer: a trial, a + probe, a fallback that re-checks. *) +let speculate env f = + env.speculating <- env.speculating + 1; + Fun.protect ~finally:(fun () -> env.speculating <- env.speculating - 1) f + +(* A refusal a caller has re-worded: recorded and stood in for while + recovering, raised otherwise. The [check] it re-words was [guarded], so its + own refusal came here rather than being recorded in its first wording. *) +let refuse_or_poison env loc (d : Loc.diag) = + if env.recovering && env.speculating = 0 then begin + record_recovered env d; + env.poison <- env.poison + 1; + poison loc + end + else raise (Loc.Error d) + +(* [f], a declaration's body, with recovery on when [on]. Everything it + recorded is raised as [Loc.Errors] at the end, together with whatever + refusal ended it, so nothing checked with a poison in it is ever returned. *) +let with_recovery env ~on f = + if not on then f () + else begin + let saved = (env.recovering, env.recovered, env.poison) in + let restore () = + let r, d, p = saved in + env.recovering <- r; env.recovered <- d; env.poison <- p + in + env.recovering <- true; env.recovered <- []; env.poison <- 0; + match f () with + | x -> + let found = List.rev env.recovered in + restore (); + if found = [] then x else raise (Loc.Errors found) + | exception Loc.Error d -> + let found = List.rev env.recovered in + restore (); + (* Raised past the end of the body after something in it already + failed: a return that does not fit, a value that is missing, both of + them what the failure left behind. *) + if found = [] then raise (Loc.Error d) else raise (Loc.Errors found) + | exception e -> restore (); raise e + end + let invented_ctx env ret = { env; ret; slots = 0; slot_tys = []; slot_names = []; scope = []; defers = []; defer_slot = None; outer = []; outer_what = None; caught = []; place_ok = false; envslot = None; parent = None; in_frames = None; loops = []; tail = false; @@ -3636,7 +4297,7 @@ let rec key_pair env loc (k : Types.t) : Tast.fnref * Tast.fnref = to that is still a refusal rather than a guessed pair. *) | Types.Var v -> Loc.failk "check/generic-map-key" loc - "a map keyed by the type variable %s has no hash and no equality here. \ + "a map keyed by the type variable $%s has no hash and no equality here. \ Write {:where (hashable? $%s)} at the head of the body, or write the \ operation in a function over the concrete key type and call that" v v | Types.String -> Tast.Rtfn "flan_hash_str", Tast.Rtfn "flan_eq_str" @@ -4152,7 +4813,162 @@ let tracked_call loc env name (tr : Shim.track) ret (args : Tast.expr list) = (* Every expression goes through here, and [check_value] is the one that knows the forms. What this adds is [refuse_owned_copy], asked of whatever came back unless the form was checked as the target of a place. *) + +(* The conditions [check_truthy] has refused, each with the body it was + checked in and its diagnostic, for as long as the outermost call is on the + stack — see [check_truthy]. Physical identity on both, since a generic's + body is the same syntax checked again at another type. *) +let truthy_failed : + (Ast.expr * (string * binding) list * Types.t * Loc.diag) list ref = ref [] + +(* Whether two scopes bind the same names at the same types, which is what a + refusal under them can depend on — the slots are fresh on every pass. A + memo keyed on less would replay a refusal after a retry changed a type. *) +let same_scope (a : (string * binding) list) (b : (string * binding) list) = + a == b + || List.equal + (fun (n, (x : binding)) (m, (y : binding)) -> + String.equal n m && Types.equal x.bty y.bty) + a b +let truthy_depth = ref 0 + +(* The same for an [if], keyed on its condition and the expectation: + an [if] whose else arm is tried on its own terms first (see [check_if]) + would otherwise be re-checked, refused, by the trial of every [if] above + it — the square of a refused or/and chain's length. *) +let if_failed : + (Loc.t, + Ast.expr * ((string * binding) list * Types.t) * Types.t option * Loc.diag) + Hashtbl.t = + Hashtbl.create 16 +let if_depth = ref 0 + + +(* A Vec or a Map parameter is a copy of the caller's header — Odin's rule — + so growing it reallocates a block only this function's copy points at, and + the caller's container never sees the elements. The function being checked + and its container parameters, by slot, and the warnings found so far, one + per parameter, printed by [build_program]. A stack because a generic's copy + is checked from inside the body that called it. *) +let grow_params : (ctx * (int * Ast.field) list) list ref = ref [] +let grow_warnings : Loc.diag list ref = ref [] + +let note_grown ctx op loc (target : Tast.expr) = + (* The parameter the container is reached from, through struct fields + taken by value — a field of a parameter is in the parameter's copy too — + and the path written back out. A [Deref] ends the walk: through a + pointer the caller's own storage is what grows. *) + let rec root (e : Tast.expr) = + match e.Tast.e with + | Tast.Local s -> Some (s, fun p -> p) + | Tast.Field (inner, i) -> + (match inner.Tast.ty with + | Types.Named n -> + (match Hashtbl.find_opt ctx.env.structs n with + | Some st when i < List.length st.Tast.fields -> + let f = (List.nth st.Tast.fields i).Tast.fname in + Option.map + (fun (s, path) -> (s, fun p -> Printf.sprintf "(.%s %s)" f (path p))) + (root inner) + | _ -> None) + | _ -> None) + | _ -> None + in + match target.Tast.ty, root target, !grow_params with + | ((Types.Vec _ | Types.Map _) as t), Some (s, path), (c, ps) :: _ when c == ctx -> + (match List.assoc_opt s ps with + | Some (p : Ast.field) + when not + (List.exists + (fun (d : Loc.diag) -> d.Loc.dloc = p.Ast.floc) + !grow_warnings) -> + let ts = Types.to_string t in + let msg = + match target.Tast.e with + | Tast.Local _ -> + Printf.sprintf + "%s is a %s passed by value, a copy of the caller's header, so \ + the %s at %s grows this function's copy and the caller's \ + container never sees it. Take it as (Ptr %s) and write (%s \ + (deref %s) ...), and each caller passes (addr c) for its \ + container c" + p.Ast.fname ts op (Loc.to_string loc) ts op p.Ast.fname + | _ -> + let pt = Types.to_string (List.nth ctx.slot_tys (ctx.slots - 1 - s)) in + Printf.sprintf + "%s is a %s passed by value, a copy of the caller's, so the %s \ + at %s grows %s in this function's copy and the caller's never \ + sees it. Take it as (Ptr %s), where %s reaches the caller's own, \ + and each caller passes (addr c) for its %s c" + p.Ast.fname pt op (Loc.to_string loc) (path p.Ast.fname) pt + (path p.Ast.fname) pt + in + grow_warnings := + Loc.diag ~kind:"check/grown-parameter" p.Ast.floc msg :: !grow_warnings + | _ -> ()) + | _ -> () + +(* Recovery, when [env.recovering] is on: a subexpression that is refused is + recorded and stands as a [poison] of type [Never], which fits any want, so + checking carries on around it and every error in a body is reported. What + an earlier failure causes is not reported: an error raised by a node one of + whose subexpressions failed, or with [Never] wanted, is dropped, as long as + something has been recorded. That last condition keeps a poison from ever + reaching a backend unreported — a scope with a poison in it always ends in + a raise (see [with_recovery]). *) let rec check ctx ?want (e : Ast.expr) : Tast.expr = + let env = ctx.env in + let guarded = env.guard_next in + env.guard_next <- false; + if (not env.recovering) || env.speculating > 0 || guarded then + check_plain ctx ?want e + else begin + let seen = env.poison in + let caused () = + env.recovered <> [] + && (env.poison > seen || want = Some Types.Never) + in + match check_plain ctx ?want e with + | r -> + if is_poison r then env.poison <- env.poison + 1; + r + | exception Loc.Error d -> + if not (caused ()) then begin + record_recovered env d; + (* A call refused as a whole — the wrong number of arguments, say — + never checked its arguments, and a mistake inside one is still a + mistake. They are checked on their own, with no expectation, so + only what no expectation could change is kept: a name that is not + there. *) + match e.Ast.e with + | Ast.Call (_, args) -> recheck_args ctx args + | _ -> () + end; + env.poison <- env.poison + 1; + poison e.Ast.loc + (* A checker arm that was never written for a [Never] operand may fail + some other way over one. Only then, and only as a consequence. *) + | exception (Not_found | Invalid_argument _ | Failure _ | Assert_failure _ + | Match_failure _) when caused () -> + env.poison <- env.poison + 1; + poison e.Ast.loc + end + +and recheck_args ctx (args : Ast.expr list) = + let env = ctx.env in + let before = env.recovered in + List.iter (fun a -> ignore (check ctx a)) args; + let rec fresh l = if l == before then [] else match l with [] -> [] | d :: r -> d :: fresh r in + let kept = + List.filter + (fun (d : Loc.diag) -> + String.starts_with ~prefix:"check/unknown-" d.Loc.kind + || String.equal d.Loc.kind "check/private") + (fresh env.recovered) + in + env.recovered <- kept @ before + +and check_plain ctx ?want (e : Ast.expr) : Tast.expr = let place = ctx.place_ok in ctx.place_ok <- false; let r = check_value ctx ?want e in @@ -4217,14 +5033,14 @@ and check_value ctx ?want (e : Ast.expr) : Tast.expr = | Some (Types.Int k) -> not (Types.signed k) | _ -> false) -> let t = Option.get want in - let gname, _, at = List.nth ctx.env.chain (List.length ctx.env.chain - 1) in + (* [instantiate] adds the note naming the call that asked for this copy. *) + let gname, _, _ = List.nth ctx.env.chain (List.length ctx.env.chain - 1) in let var = match List.find_opt (fun (_, u) -> Types.equal u t) ctx.env.subst with | Some (v, _) -> Printf.sprintf "$%s = %s" v (Types.to_string t) | None -> Types.to_string t in Loc.failk literal_at_want loc - ~notes:[ Loc.note at (Printf.sprintf "%s is instantiated at %s here" gname var) ] "%Ld does not fit in %s, which holds no negative number, and %s is called \ at %s — the body has to work at every type it is called at, so write \ it with no negative literal, as in (- x %Ld) in place of (+ x %Ld)" @@ -4368,6 +5184,23 @@ and check_value ctx ?want (e : Ast.expr) : Tast.expr = (mk loc Types.Dyn (Tast.Let ([ (m, empty) ], sets @ [ mval ]))) | Ast.Quote _ -> unimplemented loc "a quoted symbol (restart names)" 6 + (* A length variable read as a value is the integer it was bound to, as a + literal — so it takes its width from where it stands, the way a written + 8 would. In the abstract pass it is a 1: a literal that fits every + integer type, since the real one is answered again per copy. A local of + the same name shadows it. *) + | Ast.Var name + when (not (List.mem_assoc name ctx.scope)) + && (List.mem name ctx.env.lenvars + || (match List.assoc_opt name ctx.env.subst with + | Some (Types.Len _) -> true + | _ -> false)) -> + let n = + match List.assoc_opt name ctx.env.subst with + | Some (Types.Len n) -> n + | _ -> 1L + in + check ctx ?want { e with Ast.e = Ast.Int n } | Ast.Var name -> var ctx loc ~want name | Ast.Do body -> ctx.tail <- tail; block ctx ?want loc body (* [defer_ok] rides through: a [let] at the top level of a function body has @@ -4508,7 +5341,7 @@ and check_value ctx ?want (e : Ast.expr) : Tast.expr = (match Tast.field_index s name with | None -> Loc.failk "check/unknown-field" loc ~notes:(declared_note ctx.env sname) - "%s has no field %s" sname name + "%s has no field %s" (Types.to_string (Types.Named sname)) name | Some i -> let fty = (List.nth s.Tast.fields i).Tast.fty in expect ctx loc ~want (mk loc fty (Tast.Field (target, i)))) @@ -5566,6 +6399,9 @@ and check_let ctx ?(tail = false) ?want ?(defer_ok = false) loc bs body = let want = Option.map (resolve ctx.env) b.Ast.bty in let v = check ctx ?want b.Ast.bval in (match v.Tast.ty with + (* A refused initialiser, already reported: the name is bound to + the poison so that what follows is still checked. *) + | Types.Never when is_poison v -> () | Types.Unit | Types.Never -> fail b.Ast.bloc "%s would be bound to %s, which is not a value" b.Ast.bname (Types.to_string v.Tast.ty) @@ -5796,6 +6632,9 @@ and check_loop ctx ?want loc bs body = (fun (n, v) -> let v = check ctx v in (match v.Tast.ty with + (* A refused initialiser, already reported: the name is bound to + the poison so that what follows is still checked. *) + | Types.Never when is_poison v -> () | Types.Unit | Types.Never -> fail v.Tast.loc "%s would be bound to %s, which is not a value" n (Types.to_string v.Tast.ty) @@ -5948,12 +6787,12 @@ and check_recur ctx ~tail loc args = literals gets the nicer message, not just the speed. The cost that buys is real: nested [not] on a program that does not type-check re-runs this whole function once per level of nesting inside the level above it, - which is exponential in how deep the nesting goes — moot for a program - that compiles, since neither retry ever fires, and moot for ordinary - nesting depths, but visible within a second or so around twenty levels - of a [not] wrapped in a [not] wrapped in .... The dev daemon is the one - caller that could feel this, recompiling a half-typed form on every - edit; nobody has hit it in practice and it is not fixed here. + which would be exponential in how deep the nesting goes. What keeps it + linear is [truthy_failed]: a condition this function has already refused, + in the same body, is refused again with the same diagnostic rather than + re-checked, so a retry re-walks its subtree once and stops at the first + condition below it that was settled. The message is the one the first + pass produced, so no message changes. Keywords are a separate, deliberate loss rather than a bug: a bare [:kw] used to be checked here with [want:Types.Bool] from the start, so @@ -5968,8 +6807,35 @@ and check_recur ctx ~tail loc args = test_flan.ml pins the new answer down so it is not lost again by accident. *) and check_truthy ctx c = + (* Only where a refusal is raised: while recovering, one is recorded where + it happens and the check goes on, so a replayed one would hide others. *) + if ctx.env.recovering && ctx.env.speculating = 0 then check_truthy_once ctx c + else + match + List.find_opt + (fun (n, sc, r, _) -> n == c && r == ctx.ret && same_scope sc ctx.scope) + !truthy_failed + with + | Some (_, _, _, d) -> raise (Loc.Error d) + | None -> + let scope = ctx.scope in + incr truthy_depth; + Fun.protect + ~finally:(fun () -> + decr truthy_depth; + if !truthy_depth = 0 then truthy_failed := []) + (fun () -> + try check_truthy_once ctx c + with Loc.Error d as ex -> + truthy_failed := (c, scope, ctx.ret, d) :: !truthy_failed; + raise ex) + +and check_truthy_once ctx c = let loc = c.Ast.loc in - match check ctx c with + (* Speculative, because a refusal here is answered by asking again at + [bool]; and that second ask is guarded, because its refusal is re-worded + below. Recovery sees each refusal once, in its final words. *) + match speculate ctx.env (fun () -> check ctx c) with | c0 when c0.Tast.ty = Types.Dyn -> widen loc Types.Bool (rt loc (Types.Int Types.I32) "flan_dyn_truthy" [ c0 ]) | c0 when Types.fits ~expected:Types.Bool ~actual:c0.Tast.ty -> c0 @@ -5995,10 +6861,11 @@ and check_truthy ctx c = Anything more complicated than a name gets the operator and no template: a reconstructed expression would be a guess at code the reader can see for themselves. *) - (match check ctx ~want:Types.Bool c with + (ctx.env.guard_next <- true; + match check ctx ~want:Types.Bool c with | c1 -> c1 | exception Loc.Error d when not (String.equal d.Loc.kind "check/type-mismatch") -> - raise (Loc.Error d) + refuse_or_poison ctx.env loc d | exception Loc.Error _ -> let how = let zero = match c0.Tast.ty with Types.Float _ -> "0.0" | _ -> "0" in @@ -6010,12 +6877,38 @@ and check_truthy ctx c = | _, true -> Printf.sprintf " — test it against %s with !=" zero | _ -> "" in - Loc.failk "check/condition-not-bool" loc - "a condition is a bool or a dyn, and this is %s%s" - (Types.to_string c0.Tast.ty) how) + (try + Loc.failk "check/condition-not-bool" loc + "a condition is a bool or a dyn, and this is %s%s" + (Types.to_string c0.Tast.ty) how + with Loc.Error d -> refuse_or_poison ctx.env loc d)) | exception Loc.Error _ -> check ctx ~want:Types.Bool c and check_if ctx ?(tail = false) ?want loc c t e = + if ctx.env.recovering && ctx.env.speculating = 0 then + check_if_once ctx ~tail ?want loc c t e + else + match + List.find_opt + (fun (n, (sc, r), w, _) -> + n == c && r == ctx.ret && w = want && same_scope sc ctx.scope) + (Hashtbl.find_all if_failed c.Ast.loc) + with + | Some (_, _, _, d) -> raise (Loc.Error d) + | None -> + let scope = ctx.scope in + incr if_depth; + Fun.protect + ~finally:(fun () -> + decr if_depth; + if !if_depth = 0 then Hashtbl.reset if_failed) + (fun () -> + try check_if_once ctx ~tail ?want loc c t e + with Loc.Error d as ex -> + Hashtbl.add if_failed c.Ast.loc (c, (scope, ctx.ret), want, d); + raise ex) + +and check_if_once ctx ~tail ?want loc c t e = let c = check_truthy ctx c in (* Both arms are the tail, and a one-armed [if] counts: [(when c (recur ...))] is how nearly every loop is written, and the branch is still the last @@ -6059,6 +6952,34 @@ and check_if ctx ?(tail = false) ?want loc c t e = want = None && (match t.Tast.ty with Types.Slice _ | Types.Ptr _ -> true | _ -> false) in + (* A bool arm and a dyn arm meet at dyn, the bool boxed — Clojure's rule, + so (or false (box "s")) answers "s" rather than unboxing the string at + bool and trapping. The other order already met at dyn, the then arm + deciding. So after a bool then arm the else arm is checked on its own + terms first, since checking it at bool is what unboxes it, and kept + when it is a bool or a dyn. Anything else is abandoned and checked at + bool as before, for that path's messages. A chain whose arms all fit + is checked once; a refused one re-checks each level below the refusal + once more, the square of its depth. *) + let own_else = + if want = None && t.Tast.ty = Types.Bool then + match + trial ctx (fun () -> + let v = branch ctx (fun () -> in_tail (fun () -> check ctx e)) in + match v.Tast.ty with + | Types.Bool | Types.Dyn | Types.Never -> v + | _ -> raise (Loc.Error (Loc.diag v.Tast.loc "not bool or dyn"))) + with + | Ok v -> Some v + | Error _ -> None + else None + in + let t = + match own_else with + | Some v when v.Tast.ty = Types.Dyn -> + expect ctx t.Tast.loc ~want:(Some Types.Dyn) t + | _ -> t + in let ewant = match want with | Some _ -> want @@ -6080,15 +7001,26 @@ and check_if ctx ?(tail = false) ?want loc c t e = location; and with an expectation in hand both arms are checked against it rather than against each other, so nothing here runs. *) let e = - match branch ctx (fun () -> in_tail (fun () -> check ctx ?want:ewant e)) with + match own_else with + | Some v -> v + | None -> + let reworded = want = None && and_sentinel e in + match + branch ctx (fun () -> + in_tail (fun () -> + if reworded then ctx.env.guard_next <- true; + check ctx ?want:ewant e)) + with | v -> v | exception Loc.Error d - when want = None && and_sentinel e - && String.equal d.Loc.kind "check/type-mismatch" -> - Loc.failk "check/shortcircuit-operand" t.Tast.loc - "an and answers false or its last operand, so the two have to be \ - one type — this operand is %s, and false is a bool" - (Types.to_string t.Tast.ty) + when reworded && String.equal d.Loc.kind "check/type-mismatch" -> + (try + Loc.failk "check/shortcircuit-operand" t.Tast.loc + "an and answers false or its last operand, so the two have to be \ + one type — this operand is %s, and false is a bool" + (Types.to_string t.Tast.ty) + with Loc.Error d -> refuse_or_poison ctx.env e.Ast.loc d) + | exception Loc.Error d when reworded -> refuse_or_poison ctx.env e.Ast.loc d in let t, e = match free_join, Types.const_join t.Tast.ty e.Tast.ty with @@ -6130,6 +7062,167 @@ and callable ctx name = | Some b -> (match b.bty with Types.Fn _ -> true | _ -> false) | None -> false) +(* [(Pair 1 2)] and [(Pair {.a 1 .b 2})]: which copy of a generic struct a + value builds. The position says, when a copy of this struct is wanted + there; otherwise the fields do, each given one's type binding the + template's variables the way a generic call's arguments bind its own. The + fields are only probed here — each check is abandoned — and the ordinary + constructor checks them again against the copy it is handed. *) +and generic_ctor ctx ~want loc name given = + let env = ctx.env in + let g = Hashtbl.find env.gstructs name in + match want with + | Some (Types.Named k) + when (match Hashtbl.find_opt struct_apps k with + | Some (h, _) -> String.equal h name + | None -> false) -> + realise env loc (Types.Named k); k + | _ -> + let open_key = + struct_copy env loc name (List.map (fun (p, _) -> Types.Var p) g.gparams) + in + let fields = (Hashtbl.find env.structs open_key).Tast.fields in + let pairs = + match given with + | `Positional args when List.length args = List.length fields -> + List.combine fields args + (* The wrong number of fields: the copy at variables is handed on, and + the constructor says what is wrong with the count in its own words. *) + | `Positional _ -> [] + | `Named kvs -> + List.filter_map + (fun (f, v) -> + List.find_opt + (fun (fl : Tast.field) -> String.equal fl.Tast.fname f) fields + |> Option.map (fun fl -> (fl, v))) + kvs + in + let subst = ref [] and unsure = ref [] in + (* An untyped literal has no type of its own to bring, so the fields that + do have one bind first: [(Node 2 (addr c))] over a [(Node i64)] [c] is + a [(Node i64)], and the 2 takes its width from that. *) + let literal (a : Ast.expr) = + match a.Ast.e with + | Ast.Int _ | Ast.UInt _ | Ast.Float _ | Ast.Byte _ -> true + | _ -> false + in + (* A literal's own type, the one it has with nothing expected of it. *) + let literal_type (a : Ast.expr) = + match a.Ast.e with + | Ast.Float _ -> Types.Float Types.F64 + | Ast.UInt _ -> Types.Int Types.U64 + | Ast.Byte _ -> Types.Int Types.U8 + | _ -> Types.Int Types.I32 + in + let pairs = + List.filter (fun (_, a) -> not (literal a)) pairs + @ List.filter (fun (_, a) -> literal a) pairs + in + (* Variables only literals have bound so far: a later literal may widen + them, as a generic call's literal arguments meet at the wider type — + [(Pair 1 2.5)] is a [(Pair f64)]. *) + let lit_only = ref [] in + (* Which field's value decided each variable, for the refusal of a + literal that does not fit what it decided. *) + let decided_by = ref [] in + List.iter + (fun ((f : Tast.field), (a : Ast.expr)) -> + match f.Tast.fty with + (* A literal at a variable a typed field already decided: it has to + be usable at that type, and when it is not the refusal names the + field that decided it. *) + | Types.Var v + when literal a && List.mem_assoc v !subst + && not (List.mem v !lit_only) -> + let b = List.assoc v !subst in + (match a.Ast.e, b with + | Ast.Float x, Types.Int _ -> + let notes = + match List.assoc_opt v !decided_by with + | Some (fname, at) -> + [ Loc.note at + (Printf.sprintf ".%s is %s here, which decides $%s" fname + (Types.to_string b) v) ] + | None -> [] + in + Loc.failk "check/generic-struct-field" a.Ast.loc ~notes + "%s's .%s is $%s, which is %s here, and %g is a float literal. \ + Write .%s as an integer, or give .%s a float type" + name f.Tast.fname v (Types.to_string b) x f.Tast.fname + (match List.assoc_opt v !decided_by with + | Some (fname, _) -> fname + | None -> f.Tast.fname) + | _ -> ()) + | Types.Var v when literal a && not (List.mem_assoc v !subst && not (List.mem v !lit_only)) -> + let t = (literal_type a) in + (match List.assoc_opt v !subst with + | None -> subst := (v, t) :: !subst; lit_only := v :: !lit_only + | Some b -> + (match Types.join b t with + | Some j -> subst := (v, j) :: List.remove_assoc v !subst + | None -> + fail a.Ast.loc "%s's .%s is %s here, and this is %s" + (Types.to_string (Types.Named open_key)) f.Tast.fname + (Types.to_string b) (Types.to_string t))) + | _ -> + if open_ty f.Tast.fty + && not (literal a && subst_ty !subst f.Tast.fty |> open_ty |> not) + then begin + let seen = ref None in + let probe () = + seen := Some (check ctx a).Tast.ty; + Loc.fail a.Ast.loc "probe" + in + let refusal = match trial ctx probe with Error d -> Some d | Ok _ -> None in + match !seen with + (* No type of its own — [None], a bare {.field v} — is no + evidence; the constructor checks it against the copy the other + fields decide, and its refusal is the one given if they decide + nothing. *) + | None -> Option.iter (fun d -> unsure := d :: !unsure) refusal + | Some t -> + let before = !subst in + if bind_ty subst f.Tast.fty t then + List.iter + (fun (v, _) -> + if not (List.mem_assoc v before) then + decided_by := (v, (f.Tast.fname, a.Ast.loc)) :: !decided_by) + !subst + else + fail a.Ast.loc "%s's .%s is %s here, and this is %s" + (Types.to_string (Types.Named open_key)) f.Tast.fname + (Types.to_string (subst_ty !subst f.Tast.fty)) + (Types.to_string t) + end) + pairs; + (match given with + | `Positional args when List.length args <> List.length fields -> open_key + | _ -> + let targs = + List.map + (fun (p, _) -> + match List.assoc_opt p !subst with + | Some t -> t + | None -> + (match List.rev !unsure with + | d :: _ -> Loc.raise_diag d + | [] -> ()); + Loc.failk "check/generic-struct-undetermined" loc + ~notes:[ Loc.note g.gloc (name ^ " is declared here") ] + "%s's $%s is not decided by the fields given here. Name the \ + type where the value goes, as in (the (%s %s) ...)" + name p name + (String.concat " " + (List.map + (fun (q, is_len) -> + if env.tyvars <> [] then "$" ^ q + else if is_len then "8" + else "i32") + g.gparams))) + g.gparams + in + struct_copy env loc name targs) + (* [(Cell 1 2)] — a struct built from its fields in declaration order. The parser cannot make this one either, and for a sharper reason than the @@ -6159,6 +7252,14 @@ and positional_struct ctx ~want loc name args = let n = List.length fields in let given = List.length args in let note = declared_note ctx.env name in + (* The constructor is written with the template's name for a generic + struct's copy, and the copy is spoken of as [(Pair i32)]. *) + let ctor = + match Hashtbl.find_opt struct_apps name with + | Some (g, _) when Hashtbl.mem ctx.env.copies name -> g + | _ -> name + in + let shown = Types.to_string (Types.Named name) in if given < n then begin let missing = List.nth fields given in Loc.failk "check/positional-too-few" loc ~notes:note @@ -6166,15 +7267,15 @@ and positional_struct ctx ~want loc name args = Positional construction gives every field, in declaration order; to \ give some of them and zero the rest, a struct value is written (%s \ {.field value ...})" - name n (if n = 1 then "" else "s") given - (if given = 1 then "was" else "were") missing.Tast.fname name + shown n (if n = 1 then "" else "s") given + (if given = 1 then "was" else "were") missing.Tast.fname ctor end; if given > n then begin let extra = List.nth args n in Loc.failk "check/positional-too-many" extra.Ast.loc ~notes:note "%s has %d field%s, and this is argument %d — a struct value is written \ (%s {.field value ...}) or (%s %s)" - name n (if n = 1 then "" else "s") (n + 1) name name + shown n (if n = 1 then "" else "s") (n + 1) ctor ctor (String.concat " " (List.map (fun (f : Tast.field) -> f.Tast.fname) fields)) end; (* Left to right, each against its own field's type, exactly as the argument @@ -6190,16 +7291,19 @@ and positional_struct ctx ~want loc name args = let fields = map2_lr (fun (f : Tast.field) (a : Ast.expr) -> + ctx.env.guard_next <- true; try check ctx ~want:f.Tast.fty a with | Loc.Error d when d.Loc.dloc = a.Ast.loc -> - Loc.raise_diag - { d with - Loc.notes = - d.Loc.notes - @ [ Loc.note a.Ast.loc - (Printf.sprintf "this is %s's field .%s" name - f.Tast.fname) ] - @ note }) + refuse_or_poison ctx.env a.Ast.loc + (Loc.sort_notes + { d with + Loc.notes = + d.Loc.notes + @ [ Loc.note a.Ast.loc + (Printf.sprintf "this is %s's field .%s" shown + f.Tast.fname) ] + @ note }) + | Loc.Error d -> refuse_or_poison ctx.env a.Ast.loc d) fields args in expect ctx loc ~want (mk loc (Types.Named name) (Tast.Make (name, fields))) @@ -6257,6 +7361,9 @@ and check_bare ctx ~want loc kvs = what lets the decision be made against the tables, exactly. *) and check_struct ctx ~want loc name kvs = match Hashtbl.find_opt ctx.env.structs name with + | None when Hashtbl.mem ctx.env.gstructs name -> + check_struct ctx ~want loc + (generic_ctor ctx ~want loc name (`Named kvs)) kvs | None when Hashtbl.mem ctx.env.unions name -> check_union ctx ~want loc name kvs | None -> @@ -6332,7 +7439,7 @@ and check_struct ctx ~want loc name kvs = if Tast.field_index s k = None then Loc.failk "check/unknown-field" v.Ast.loc ~notes:(declared_note ctx.env name) - "%s has no field %s" name k) + "%s has no field %s" (Types.to_string (Types.Named name)) k) in let fields = zii_fill ctx loc seen s.Tast.fields in expect ctx loc ~want (mk loc (Types.Named name) (Tast.Make (name, fields))) @@ -6642,6 +7749,8 @@ and numbers_disagree : 'a. ctx -> (Ast.expr * Types.t) list -> 'a = that finds nothing. *) and mixed_refusal : 'a. ctx -> Ast.expr list -> Loc.diag -> 'a = fun ctx items d -> + (* Every check here only looks for a better sentence for [d]. *) + speculate ctx.env @@ fun () -> match items with | [] -> raise (Loc.Error d) | first :: rest -> @@ -6666,9 +7775,7 @@ and mixed_refusal : 'a. ctx -> Ast.expr list -> Loc.diag -> 'a = (Printf.sprintf "this array's first element is %s, so every \ element is" - (match first.Tast.ty with - | Types.Var v -> "$" ^ v - | t -> Types.to_string t)) ] })) + (Types.to_string first.Tast.ty)) ] })) rest; raise (Loc.Error d) @@ -6841,7 +7948,7 @@ and check_the ctx ~want loc (t : Ast.texpr) (v : Ast.expr) = dyn — a dyn becomes a %s where a %s is passed, returned or stored" tn tn tn | None -> - (match check ctx ~want:ty v with + (match speculate ctx.env (fun () -> check ctx ~want:ty v) with | _ -> fail v.Ast.loc "the checks a value as %s and does not convert one, and this is \ @@ -7367,6 +8474,7 @@ and ordinal n = points at the wrong form. The rekind is what stops a nested call from being named twice: once enriched, it is no longer the kind this looks for. *) and check_arg ctx name i (want : Types.t) (a : Ast.expr) = + ctx.env.guard_next <- true; match check ctx ~want a with | e -> e | exception Loc.Error d @@ -7382,9 +8490,10 @@ and check_arg ctx name i (want : Types.t) (a : Ast.expr) = name which p.Ast.fname (Types.to_string want)) ] | _ -> [] in - Loc.raise_diag + refuse_or_poison ctx.env a.Ast.loc (Loc.diag ~kind:"check/argument-type" ~notes a.Ast.loc (Printf.sprintf "%s — this is the %s argument of %s" d.Loc.dmsg which name)) + | exception Loc.Error d -> refuse_or_poison ctx.env a.Ast.loc d and fields_named env n : Tast.structure option = match Hashtbl.find_opt env.structs n with @@ -7535,7 +8644,7 @@ and check_place ?(store = true) ctx loc (p : Ast.place) : Tast.place * Types.t = (match Tast.field_index s name with | None -> Loc.failk "check/unknown-field" loc ~notes:(declared_note ctx.env sname) - "%s has no field %s" sname name + "%s has no field %s" (Types.to_string (Types.Named sname)) name | Some i -> if store then Option.iter (refuse_const_place ctx.env loc) (const_reached target); Tast.Pfield (target, i), (List.nth s.Tast.fields i).Tast.fty) @@ -7810,9 +8919,16 @@ and not_numeric name what (a : Tast.expr) = so that the family says it one way: a body with no clause is given the whole clause, and a body that already has one is told which predicate to add rather than a clause that would drop the ones it has. *) -and cast_operand ctx loc name ~needs ~what ~is v = - if declares ctx.env.tvpreds v needs then () +and cast_operand ctx loc name ~needs ?also ~what ~is v = + if declares ctx.env.tvpreds v needs + || (match also with + | Some (p, _) -> declares ctx.env.tvpreds v p + | None -> false) + then () else + (* A conversion two bounds license is refused naming both, since which one + the reader meant is theirs to say. *) + let is = match also with Some (_, is') -> is ^ " or " ^ is' | None -> is in let declared = List.filter_map (fun (p : Ast.pred) -> @@ -7828,10 +8944,19 @@ and cast_operand ctx loc name ~needs ~what ~is v = (String.concat " and " ps) is in let fix = + let alt clause = + match also with + | Some (p, is') -> + Printf.sprintf ", or %s for %s" + (Printf.sprintf clause p v) is' + | None -> "" + in if ctx.env.tvpreds = [] then - Printf.sprintf "write {:where (%s $%s)} at the head of the body" - needs v - else Printf.sprintf "add (%s $%s) to the where clause" needs v + Printf.sprintf "write {:where (%s $%s)} at the head of the body%s" + needs v (alt "{:where (%s $%s)}") + else + Printf.sprintf "add (%s $%s) to the where clause%s" needs v + (alt "(%s $%s)") in Loc.failk "check/unconstrained-type-variable" loc "%s converts %s. %s — %s" name what known fix @@ -8126,14 +9251,20 @@ and file_guard ctx loc ~path_slot ~op mk_steps = missing annotation for a program that had written one. One list, read by both callers, so the next kind of type added cannot be added to one of them. *) +(* A global value that a bare name in a type position would reach instead of + a type. A type variable in scope is not shadowed by one: the prelude's + generics write [(vec-new t)], and a program's [(defonce t ...)] must not + change what the prelude means. *) +and global_value ctx n = + Hashtbl.mem ctx.env.globals n && not (tyvar_in_scope ctx.env n) + (* An argument written as a type: a type expression, or a bare name that is a type and not a local or a global of the same spelling. *) and type_arg ctx (a : Ast.expr) = - type_of_expr a <> None + type_of_expr ~generic:(Hashtbl.mem ctx.env.gstructs) a <> None || (match a.Ast.e with | Ast.Var n -> - lookup ctx n = None && (not (Hashtbl.mem ctx.env.globals n)) - && type_named ctx n + lookup ctx n = None && not (global_value ctx n) && type_named ctx n | _ -> false) and type_named ctx n = @@ -8163,12 +9294,13 @@ and type_named ctx n = and vec_new_elem ctx ~want loc args = let named = match args with - | a :: rest when type_of_expr a <> None -> - Some (resolve ctx.env (Option.get (type_of_expr a)), rest) + | a :: rest when type_of_expr ~generic:(Hashtbl.mem ctx.env.gstructs) a <> None -> + Some + (resolve ctx.env + (Option.get (type_of_expr ~generic:(Hashtbl.mem ctx.env.gstructs) a)), + rest) | { Ast.e = Ast.Var n; _ } :: rest - when lookup ctx n = None - && (not (Hashtbl.mem ctx.env.globals n)) - && type_named ctx n -> + when lookup ctx n = None && not (global_value ctx n) && type_named ctx n -> Some (resolve_name ctx.env ~seen:[] loc n, rest) | _ -> None in @@ -8187,12 +9319,12 @@ and vec_new_elem ctx ~want loc args = brackets — an allocator is never an array — or a parenthesised Ptr, Option, Vec, Map, Fn or CFn. A bare name is not one of them, because there it may be an allocator's name; the callers ask about that themselves. *) -and type_of_expr (e : Ast.expr) : Ast.texpr option = +and type_of_expr ?(generic = fun _ -> false) (e : Ast.expr) : Ast.texpr option = let mk t = { Ast.t; tloc = e.Ast.loc } in let inner (e : Ast.expr) = match e.Ast.e with | Ast.Var s -> Some { Ast.t = Ast.Tname s; tloc = e.Ast.loc } - | _ -> type_of_expr e + | _ -> type_of_expr ~generic e in let all es = let ts = List.filter_map inner es in @@ -8216,6 +9348,18 @@ and type_of_expr (e : Ast.expr) : Ast.texpr option = | Ast.Call ({ Ast.e = Ast.Var (("Ptr" | "Option" | "Vec" | "Map") as c); _ }, (_ :: _ as args)) -> Option.map (fun ts -> mk (Ast.Tapp (c, ts))) (all args) + (* A generic struct applied to its arguments, [(vec-new (Small 8 i32))]: + the caller says which heads are ones, since only the env knows. An + integer argument is a length. *) + | Ast.Call ({ Ast.e = Ast.Var c; _ }, (_ :: _ as args)) when generic c -> + let arg (a : Ast.expr) = + match a.Ast.e with + | Ast.Int n -> Some { Ast.t = Ast.Tlen n; tloc = a.Ast.loc } + | _ -> inner a + in + let ts = List.filter_map arg args in + if List.length ts = List.length args then Some (mk (Ast.Tapp (c, ts))) + else None | _ -> None (* The key and value types, or the reason this is not a Map. *) @@ -8231,14 +9375,12 @@ and map_kv loc what (t : Types.t) = says half of a type and half is not a type. *) and map_new_types ctx ~want loc args = let is_type n = - lookup ctx n = None - && (not (Hashtbl.mem ctx.env.globals n)) - && type_named ctx n + lookup ctx n = None && not (global_value ctx n) && type_named ctx n in (* A type position holds a bare name or a type expression Parse has read as one, as [vec-new]'s does. *) let as_type (a : Ast.expr) = - match a.Ast.e, type_of_expr a with + match a.Ast.e, type_of_expr ~generic:(Hashtbl.mem ctx.env.gstructs) a with | _, Some t -> Some (resolve ctx.env t) | Ast.Var n, None when is_type n -> Some (resolve_name ctx.env ~seen:[] loc n) | _ -> None @@ -8246,7 +9388,7 @@ and map_new_types ctx ~want loc args = match args with | k :: v :: rest when as_type k <> None && as_type v <> None -> Option.get (as_type k), Option.get (as_type v), rest - | a :: _ when type_of_expr a <> None -> + | a :: _ when type_of_expr ~generic:(Hashtbl.mem ctx.env.gstructs) a <> None -> fail loc "(map-new) names a key and no value — write both, as (map-new string \ i32)" @@ -8286,8 +9428,9 @@ and alloc_value ctx loc e = use_alloc ctx loc (check ctx ~want:Types.Alloc e) holds the block so the allocation registry can read its extent, the attempt sits under [alloc_guard] so a failure signals StorageExhausted with retry, and the answer is the [slice] of the whole of it. The slice carries no - allocator, so nothing can [free] the block through it — it lives until its - allocator's free-all or destroy. + allocator: (free s) hands the block back to the context allocator or the + one named, and a dev build's registry — which the note gives the Vec's + allocator — refuses the wrong one. The source is bound before the guard's loop, so a retry re-attempts the same copy rather than re-evaluating the expression that produced it. Same @@ -8319,7 +9462,7 @@ and dup_elems ctx loc elem (src : Tast.expr) (a : Tast.expr) = (v, mk loc (Types.Vec elem) (Tast.Zero (Types.Vec elem))); (out, mk loc (Types.Slice (Types.Mut, elem)) (Tast.Zero (Types.Slice (Types.Mut, elem)))) ], [ with_note loc (alloc_guard ctx loc attempt) - (reg_note loc "flan_dev_reg_note_vec" + (reg_note loc "flan_dev_reg_note_slice" (mk loc (Types.Vec elem) (Tast.Local v)) [ size_of loc elem ] elem); fill; @@ -8732,7 +9875,7 @@ and named_call ?(qualified = false) ctx ~want loc name args = fail (List.hd args).Ast.loc "%s takes a type, as in (%s i32)" name name; let a = List.hd args in let ty = - match type_of_expr a, a.Ast.e with + match type_of_expr ~generic:(Hashtbl.mem ctx.env.gstructs) a, a.Ast.e with | Some t, _ -> resolve ctx.env t | _, Ast.Var n -> resolve_name ctx.env ~seen:[] a.Ast.loc n | _ -> fail a.Ast.loc "internal: %s's type argument is not a type" name @@ -9161,6 +10304,7 @@ and named_call ?(qualified = false) ctx ~want loc name args = [ target; check ctx ~want:Types.Dyn x; here loc ]) else begin let elem = vec_elem loc "push" target.Tast.ty in + note_grown ctx "push" loc target; let x = check ctx ~want:elem x in (* The element is bound before the loop so that a [retry] re-attempts the allocation and not the expression that produced the value. *) @@ -9192,6 +10336,7 @@ and named_call ?(qualified = false) ctx ~want loc name args = let target = check_target ctx target in refuse_const_change ctx loc target; let n = check ctx ~want:index_ty n in + note_grown ctx "reserve" loc target; let n64 = mk loc (Types.Int Types.I64) (Tast.Prim (Tast.Cast (Types.Int Types.I64), [ n ])) in @@ -9232,9 +10377,18 @@ and named_call ?(qualified = false) ctx ~want loc name args = traps a read through a released region. That is the Odin contract: free is a thing you write, and writing it twice is yours to not do. *) | "free" -> - arity ctx loc name 1 args; + (match args with + | [ _ ] | [ _; _ ] -> () + | _ -> fail loc "free is (free v), or (free s allocator) for a slice"); let target = check_target ctx (List.hd args) in refuse_const_change ctx loc target; + (match target.Tast.ty, args with + | (Types.Vec _ | Types.Map _), [ _; _ ] -> + fail loc + "a %s knows the allocator it came from, so free takes only the \ + container. Write (free %s)" + (Types.to_string target.Tast.ty) (spell_arg "v" (List.hd args)) + | _ -> ()); (* A container of owning elements is refused here, and a reader will assume the opposite — that [free] recurses — so this says why it does not and what does. @@ -9274,12 +10428,93 @@ and named_call ?(qualified = false) ctx ~want loc name args = expect ctx loc ~want (rt loc Types.Unit "flan_map_free" [ target; size_of loc k; size_of loc v; here loc ]) + (* A slice (bytes s) or (clone xs) answered: its block goes back to the + allocator it came from, which a slice does not carry — so it is the + context allocator, as Odin's delete defaults to, or the one named. A + dev build checks the block against the allocation registry and traps + on a slice that is not the start of a block, or on the wrong + allocator, instead of handing one allocator another's block. *) + | Types.Slice (Types.Const, _) -> + fail loc + "%s can only be read, so it cannot be freed. Free the [%s] it was \ + copied into" + (Types.to_string target.Tast.ty) + (match target.Tast.ty with + | Types.Slice (_, e) -> Types.to_string e + | t -> Types.to_string t) + (* A view written right here — (slice ...) or (slice-from-ptr ...) — + is storage something else owns, known without running anything. *) + | Types.Slice (Types.Mut, _) + when (match (List.hd args).Ast.e with + | Ast.Call ({ Ast.e = Ast.Var ("slice" | "slice-from-ptr"); _ }, _) -> + true + | _ -> false) -> + fail loc + "this is a view of storage something else owns, so it cannot be \ + freed. Only a slice (bytes s) or (clone xs) made can be" + | Types.Slice (Types.Mut, elem) -> + let a = allocator_arg ctx loc (List.tl args) in + expect ctx loc ~want + (rt loc Types.Unit "flan_slice_free" + [ target; size_of loc elem; align_of loc elem; a; here loc ]) | other -> (* A field is never freed on its own: it would leave its owner partly dead with no way to say so. *) fail loc - "free takes an owning container — a Vec or a Map — found %s" + "free takes a Vec, a Map, or a slice (bytes s) or (clone xs) made — \ + found %s" (Types.to_string other)) + (* Emitted by the prelude's [into] when no (map f) is in the chain, so that + every element pushed is a source element as it stands. A push copies an + element's header, and for an element that owns storage the copy and the + source then share one block: growing an element through either side + reallocates it and frees the block the other still points at. That is a + use after free the program never wrote, under a name that promised a + copy, so it is refused here. A bare (push w (at v 0)) is not: it copies a + header in plain sight, the Odin contract every container follows. + Arguments are the source, then the destination and the transforms as + written — those two only to be spelled back in the fix, never checked. *) + | "into-copies-elements" -> + (match args with + | src :: dst :: transforms -> + let s = check ctx src in + let elem = + match s.Tast.ty with + | Types.Vec e | Types.Slice (_, e) | Types.Array (_, e) -> Some e + | _ -> None + in + (match elem with + | Some e when owning ctx.env e -> + let v = spell_arg "v" src in + let et = Types.to_string e in + let fix = + if clone_accepts ctx.env e then + match spell_form dst, List.map spell_form transforms with + | Some d, ts when not (List.mem None ts) -> + Printf.sprintf + "Add (map clone) to the chain, which copies what each \ + element owns: (into %s)" + (String.concat " " + ((v :: d :: List.filter_map Fun.id ts) @ [ "(map clone)" ])) + | _ -> + "Add (map clone) to the chain, which copies what each element \ + owns" + else + Printf.sprintf + "Nothing copies what a %s owns, so no copy of %s can stand on \ + its own: read the elements where they are, or build each new \ + element and push that" + et v + in + Loc.failk "check/into-shares-elements" src.Ast.loc + "into copies each element of %s as it stands, and an element of \ + %s is a %s, which owns storage — the copy would share each \ + element's block with %s, and growing either one frees the block \ + the other points at. %s" + v v et v fix + | _ -> ()); + expect ctx loc ~want (mk loc Types.Unit Tast.Unit) + | _ -> expect ctx loc ~want (mk loc Types.Unit Tast.Unit)) (* (clone v) uses the current allocator, (clone v a) names one. A deep, independent copy: spec-memory.md's "copying is always explicit". *) | "clone" -> @@ -9315,9 +10550,9 @@ and named_call ?(qualified = false) ctx ~want loc name args = | (Types.Vec _ | Types.Map _) when region_only ctx.env target.Tast.ty -> fail loc "%s cannot be cloned — its elements own storage, and nothing here \ - can walk one to copy what it owns. Build a second container and \ - insert into it" + can walk one to copy what it owns. %s" (Types.to_string target.Tast.ty) + (insert_copies ctx.env target.Tast.ty) (* A slice's elements, copied into a block from the allocator and answered as a slice over it — what (bytes s) does for a string's bytes, and the same lowering. The same refusal as a Vec's, for the @@ -9325,9 +10560,9 @@ and named_call ?(qualified = false) ctx ~want loc name args = | Types.Slice (_, elem) when owning ctx.env elem -> fail loc "%s cannot be cloned — its elements own storage, and nothing here \ - can walk one to copy what it owns. Build a container and insert \ - into it" + can walk one to copy what it owns. %s" (Types.to_string target.Tast.ty) + (insert_copies ctx.env target.Tast.ty) (* The copy is a block from an allocator, which the collector does not walk, so a dyn in it would be a root nothing marks. *) | Types.Slice (_, elem) when holds_dyn ctx.env elem -> @@ -9437,6 +10672,7 @@ and named_call ?(qualified = false) ctx ~want loc name args = check ctx ~want:Types.Dyn v; here loc ]) else begin let kt, vt = map_kv loc "put" target.Tast.ty in + note_grown ctx "put" loc target; let k = check ctx ~want:kt k in let v = check ctx ~want:vt v in (* Deferred: the arguments are checked — so a move here is still a move @@ -10070,12 +11306,20 @@ and named_call ?(qualified = false) ctx ~want loc name args = let int k = mk loc index_ty (Tast.Int (k, Types.I32)) in (* [hi] is wanted twice only when it is the implicit length of something whose length is not static. *) + (* An array literal is also given a slot, so that what the slice views + lives for the whole function in both backends: the x86 backend + otherwise holds it in an expression temporary, reclaimed as soon as + the slice has been made, and a later temporary — (clone ...)'s own, + say — was written over it. *) let needs_slot = - List.length bounds < 2 - && (match ty with Types.Array _ -> false | _ -> true) - && (match target.Tast.e with - | Tast.Local _ | Tast.Global _ -> false - | _ -> true) + (match ty, target.Tast.e with + | Types.Array _, Tast.Arr _ -> true + | _ -> false) + || List.length bounds < 2 + && (match ty with Types.Array _ -> false | _ -> true) + && (match target.Tast.e with + | Tast.Local _ | Tast.Global _ -> false + | _ -> true) in let slot = if needs_slot then Some (fresh_slot ctx ty) else None in let src () = match slot with @@ -10146,10 +11390,9 @@ and named_call ?(qualified = false) ctx ~want loc name args = and a reader who sees it has already been told where the promise comes from. - **It owns nothing.** The result is a [Types.Slice], which carries no - allocator and is the same non-owning view (slice v) answers — so - [free] refuses it by the rule it already had ("free takes an owning - container"). *) + **It owns nothing.** The result is a [Types.Slice], the same non-owning + view (slice v) answers; (free s) on it is the program's error, which a + dev build's registry traps as a slice no allocator handed out. *) | "slice-from-ptr" -> arity ctx loc name 2 args; (match args with @@ -10427,7 +11670,7 @@ and named_call ?(qualified = false) ctx ~want loc name args = checked with [t] concrete. One generic argument defers the whole call: the printers for its neighbours would be re-selected at instantiation anyway, so building them here would be work thrown away twice. *) - if List.exists (fun a -> generic_ty a.Tast.ty) checked then + if List.exists (fun a -> open_ty a.Tast.ty) checked then mk loc Types.Unit Tast.Unit else let bslice = Types.Slice (Types.Mut, (Types.Int Types.U8)) in @@ -10456,7 +11699,20 @@ and named_call ?(qualified = false) ctx ~want loc name args = match a.Tast.ty with | Types.String | Types.Slice (_, (Types.Int Types.U8)) -> [ write (mk loc bslice (Tast.Prim (Tast.Bytes, [ a ]))) ] - | _ -> Render.render rc 0 a + (* The walk names the value once per piece it reads — an option's tag + and then its payload, each field of a struct — so anything but a + plain variable is bound to a slot first, or [(println (pop! s))] + pops once per piece. *) + | _ -> + (match a.Tast.e with + | Tast.Local _ | Tast.Global _ -> Render.render rc 0 a + | _ -> + let s = fresh_slot ctx a.Tast.ty in + [ mk loc Types.Unit + (Tast.Let + ([ (s, a) ], + Render.render rc 0 (mk a.Tast.loc a.Tast.ty (Tast.Local s)))) + ]) in (* Built fresh per use rather than shared: nothing else in this file puts one node in two places of a tree, and a pass that hangs state off a @@ -10499,7 +11755,7 @@ and named_call ?(qualified = false) ctx ~want loc name args = arity ctx loc name 2 args; let label = check ctx ~want:Types.String (List.hd args) in let v = check ctx (List.nth args 1) in - if generic_ty v.Tast.ty then mk loc Types.Unit Tast.Unit + if open_ty v.Tast.ty then mk loc Types.Unit Tast.Unit else begin let unit_rt sym args = mk loc Types.Unit (Tast.Prim (Tast.Rt sym, args)) in let bslice = Types.Slice (Types.Mut, (Types.Int Types.U8)) in @@ -10662,8 +11918,8 @@ and named_call ?(qualified = false) ctx ~want loc name args = [ordered?] admits a type that does not, and that day is why the question is asked of the predicate and not of the set it denotes. *) | Types.Var v -> - cast_operand ctx loc name ~needs:"numeric?" ~what:"a number" - ~is:"a number" v + cast_operand ctx loc name ~needs:"numeric?" ~also:("enum?", "an enum") + ~what:"a number or an enum" ~is:"a number" v | t -> fail loc "%s converts a number, found %s" name (Types.to_string t)); prim (Tast.Cast target) target [ a ] | _ when is_cast name && List.length args = 1 -> @@ -10694,8 +11950,8 @@ and named_call ?(qualified = false) ctx ~want loc name args = machine type, so what is in question is only the operand, and the [where] clause is what answers it. *) | Types.Var v -> - cast_operand ctx loc name ~needs:"numeric?" ~what:"a number" - ~is:"a number" v + cast_operand ctx loc name ~needs:"numeric?" ~also:("enum?", "an enum") + ~what:"a number or an enum" ~is:"a number" v | t -> fail loc "%s converts a number, found %s" name (Types.to_string t)); (match a.Tast.ty with | Types.Dyn -> cast_dyn ctx loc target a @@ -10723,6 +11979,16 @@ and ordinary_call ctx ~want loc name args = lifted body captures it by value and then calls the copy. [peek_outer] rather than [capture] in the guard, because a guard must not take a copy on its way to deciding what a form means. *) + (* A local bound to a refused initialiser's stand-in, called: the refusal + is already reported, so the call stands in too, its arguments still + checked. *) + | _ when ctx.env.recovering + && (match lookup ctx name with + | Some b -> Types.equal b.bty Types.Never + | None -> false) -> + List.iter (fun a -> ignore (check ctx a)) args; + ctx.env.poison <- ctx.env.poison + 1; + poison loc | _ when (match lookup ctx name with | Some b -> callable_ty b.bty | None -> @@ -10737,6 +12003,14 @@ and ordinary_call ctx ~want loc name args = match capture ctx loc name with | Some b -> call_value ctx ~want loc (mk loc b.bty (Tast.Local b.slot)) args | None -> assert false) + (* A global holding a function value — a (CFn ...) table entry's cousin, + since a global is one of the zeroed positions a CFn may sit in. Called + by its name the way a local one is. *) + | _ when (match Hashtbl.find_opt ctx.env.globals name with + | Some (ty, _) -> callable_ty ty + | None -> false) -> + let ty, _ = Hashtbl.find ctx.env.globals name in + call_value ctx ~want loc (mk loc ty (Tast.Global name)) args | _ when Hashtbl.mem ctx.env.gsigs name -> private_ref ctx loc name; let vars, params, ret = Hashtbl.find ctx.env.gsigs name in @@ -10795,6 +12069,10 @@ and ordinary_call ctx ~want loc name args = name dname dname c.Tast.vname dname c.Tast.vname else if Hashtbl.mem ctx.env.structs name then positional_struct ctx ~want loc name args + else if Hashtbl.mem ctx.env.gstructs name then + positional_struct ctx ~want loc + (generic_ctor ctx ~want loc name + (`Positional args)) args else if List.mem_assoc name operator_aliases then (* Asked before the package test, because [/=] and [=/=] have a slash in them and are not package calls. The did-you-mean cannot reach @@ -10924,10 +12202,10 @@ and ordinary_call ctx ~want loc name args = same thing here so the answer does not depend on which side of the fork the form fell down. *) Loc.failk "check/unknown-function" loc - "unknown function %s. A capitalised name is a type, and (%s \ - ...) is a generic type, which is not there yet — a generic \ - function is, written with $t in its parameter vector" - name name + "unknown function %s. A capitalised name is a type, and no \ + struct or generic struct %s is declared — a generic struct is \ + one whose fields introduce $t, as in (defstruct %s [x $t])" + name name name else Loc.failk "check/unknown-function" loc "unknown function %s" name (* Does the program's own definition of this name take this call over? @@ -11081,9 +12359,14 @@ and generic_call ctx ~want loc name vars pats pret args = | Types.Var u -> String.equal u v | Types.Slice (_, e) | Types.Array (_, e) | Types.Ptr (_, e) | Types.Vec e | Types.Option e -> mentions v e + | Types.LArray (u, e) -> String.equal u v || mentions v e | Types.Map (k, w) -> mentions v k || mentions v w | Types.Fn (ps, r) | Types.CFn (ps, r) -> List.exists (mentions v) ps || mentions v r + | Types.Named k -> + (match Hashtbl.find_opt struct_apps k with + | Some (_, args) -> List.exists (mentions v) args + | None -> false) | _ -> false in let bound_exactly v = @@ -11111,7 +12394,7 @@ and generic_call ctx ~want loc name vars pats pret args = the [sort-by] path below is untouched by construction. *) let bound_scalar = match pat with - | Types.Var v when (not (generic_ty p)) && Types.is_numeric p -> + | Types.Var v when (not (open_ty p)) && Types.is_numeric p -> Some v | _ -> None in @@ -11132,11 +12415,11 @@ and generic_call ctx ~want loc name vars pats pret args = let bound_view = match pat, p with | Types.Var v, (Types.Slice _ | Types.Ptr _) - when not (generic_ty p || bound_exactly v) -> Some v + when not (open_ty p || bound_exactly v) -> Some v | _ -> None in let a = - if generic_ty p || bound_view <> None then check ctx a + if open_ty p || bound_view <> None then check ctx a else if bound_scalar <> None && not untyped_literal then (* On its own terms first. A form that has no type without a want — [(zeroed)] is the one that matters — refuses here and is @@ -11341,7 +12624,8 @@ and generic_call ctx ~want loc name vars pats pret args = !subst; let cparams = List.map (subst_ty !subst) pats in let cret = subst_ty !subst pret in - if List.exists generic_ty cparams || generic_ty cret then begin + List.iter (realise ctx.env loc) (cret :: cparams); + if List.exists open_ty cparams || open_ty cret then begin (* One generic function calling another at its *own* variable, seen from the abstract pass over the caller's body — [sort-by] calling [swap] at [t]. There is no copy to make yet: [t] is not a type. The node is @@ -11367,10 +12651,10 @@ and generic_call ctx ~want loc name vars pats pret args = | Some (Types.Var v) when not (declares ctx.env.tvpreds v p.Ast.pname) -> Loc.failk "check/predicate-not-carried" loc "%s is written {:where (%s $%s)}, and this call passes the \ - type variable %s, which nothing here declares %s. Add \ + type variable $%s, which nothing here declares %s. Add \ {:where (%s $%s)} to this function's own clause" name p.Ast.pname p.Ast.pvar v p.Ast.pname p.Ast.pname v - | Some t when not (generic_ty t) && not (pred_holds p.Ast.pname t) -> + | Some t when not (open_ty t) && not (pred_holds p.Ast.pname t) -> Loc.failk "check/predicate-unsatisfied" loc "%s is written {:where (%s $%s)}, and this call passes %s, \ which is not %s" @@ -11445,19 +12729,83 @@ and instantiate env loc gname vars subst cparams cret = concrete as one written out by hand. The [where] clause goes out of scope with them — there is nothing abstract left for it to permit, and every operator is answered by the concrete type it now has. *) + let saved_lens = env.lenvars and saved_ph = env.len_placeholder in env.subst <- List.map (fun v -> (v, List.assoc v subst)) vars; env.tyvars <- []; + env.lenvars <- []; + env.len_placeholder <- false; env.tvpreds <- []; env.chain <- env.chain @ [ (gname, cparams, loc) ]; let restore () = env.subst <- saved_subst; env.tyvars <- saved_vars; - env.tvpreds <- saved_preds; env.chain <- saved_chain + env.tvpreds <- saved_preds; env.chain <- saved_chain; + env.lenvars <- saved_lens; env.len_placeholder <- saved_ph in + if Hashtbl.mem env.refused_generics gname then begin + restore (); + sym + end else let tfn = - match !check_fn_ref env { fn with Ast.name = sym } with + (* Without recovery: a copy that does not check is refused whole, at + the call that asked for it, as it always was. *) + match speculate env (fun () -> !check_fn_ref env { fn with Ast.name = sym }) with | tfn -> restore (); tfn | exception e -> restore (); + (* The refusal is inside the generic's source, which says nothing about + which call asked for this copy; the note names it. Nested copies + each add their own, so the notes walk the chain back to the call + the programmer wrote. *) + let at () = + String.concat ", " + (List.map + (fun v -> Printf.sprintf "$%s = %s" v + (Types.to_string (List.assoc v subst))) + vars) + in + let in_prelude (l : Loc.t) = String.equal l.Loc.file Prelude.file in + let e = + match e with + (* A prelude generic's body is source nobody at this call wrote, and + an editor cannot jump to it. The refusal moves to the call that + asked for the copy, and the prelude's line comes along as a + note. *) + | Loc.Error d when in_prelude d.Loc.dloc && not (in_prelude loc) -> + (* Only the reason comes along. The rest of the body's message is + a fix to the body, which the caller cannot make. *) + let reason = + let cut sep m = + match find_sub m sep with + | Some i -> String.sub m 0 i + | None -> m + in + cut ". " (cut " — " d.Loc.dmsg) + in + Loc.Error + (Loc.sort_notes + { d with + Loc.dloc = loc; + dmsg = + Printf.sprintf + "%s cannot be made at %s: its body in the prelude does \ + not compile at that type. Pass a value of a type it \ + takes, or write the operation here" + gname (at ()); + notes = + d.Loc.notes + @ [ Loc.note d.Loc.dloc ("in the prelude, " ^ reason) ]; + expansion = None }) + | Loc.Error d when d.Loc.dloc <> loc -> + Loc.Error + (Loc.sort_notes + { d with + Loc.notes = + d.Loc.notes + @ [ Loc.note loc + (Printf.sprintf "%s is instantiated at %s here" + gname (at ())) ] }) + | e -> e + in (* A copy whose body did not check is not a copy. Both entries go back out, so a second call at the same types is the same refusal again rather than a cache hit on a function that does not exist. *) @@ -11577,7 +12925,7 @@ and trial ctx f = outer_what; caught; place_ok; envslot; parent = _; in_frames; loops; tail; in_defer; owner = _ } = ctx in - match f () with + match speculate ctx.env f with | r -> Ok r | exception Loc.Error d -> ctx.slots <- slots; ctx.slot_tys <- slot_tys; @@ -11867,16 +13215,22 @@ let builtins : (string * string * string) list = "Makes room for n more. For a map the number is entries rather than \ slots — the block is sized so that n still sits under the load \ factor."); - ("free", "free [(Vec T)|(Map K V)] ()", + ("free", "free [(Vec T)|(Map K V)|[T] Allocator?] ()", "Releases the container's block. It does not recurse into elements that \ own storage — such a container is refused here, and releasing its \ - region with free-all is the answer."); + region with free-all is the answer. A slice (bytes s) or (clone xs) \ + made goes back to the current allocator, or the one named; a dev build \ + traps on a slice from another allocator or not from one at all."); ("clone", "clone [(Vec T)|(Map K V)|[T] Allocator?] (Vec T)|(Map K V)|[T]", "A deep, independent copy, from the current allocator or one named. \ - A slice's copy is a slice over a new block, which lives until its \ - allocator's free-all or destroy. Refused for elements that own \ + A slice's copy is a slice over a new block, released by (free s) or by \ + its allocator's free-all. Refused for elements that own \ storage: a bytewise copy would alias the original's blocks under a \ name promising otherwise."); + ("into-copies-elements", "into-copies-elements [src dst transform...] ()", + "What into writes when its chain has no (map f). Refuses a source whose \ + elements own storage, because pushing them as they stand would share \ + their blocks. Not meant to be written by hand."); (* (Map K V) *) ("map-new", "map-new [K? V? Allocator?] (Map K V)", @@ -11982,8 +13336,8 @@ let builtins : (string * string * string) list = ("bytes", "bytes [string Allocator?] [u8]", "A writable copy of the string's bytes, from the current allocator or \ one named. It allocates like vec-new does — a failure signals \ - StorageExhausted with retry — and the block lives until its \ - allocator's free-all or destroy. For reading without a copy, \ + StorageExhausted with retry — and (free b) releases it, through the \ + current allocator or (free b a) through the one it came from. For reading without a copy, \ bytes-view."); ("bytes-view", "bytes-view [string] [const u8]", "The string's own storage seen as a read-only byte slice. It costs \ @@ -12270,10 +13624,28 @@ let collect env (decls : Ast.decl list) = | None -> ()); Hashtbl.add claimed n d.Ast.dloc) decls; + (* A defstruct whose fields introduce a variable is a template. *) + let generic_fields (fs : Ast.field list) = + let vs, _, _ = + sigil_vars ~kinds_of:(fun _ -> None) + (List.map (fun (f : Ast.field) -> f.Ast.fty) fs) + in + vs <> [] + in + let gpending = Hashtbl.create 4 in (* Names first, so a struct may mention one declared below it. *) List.iter (fun (d : Ast.decl) -> match d.Ast.d with + | Ast.Defstruct (n, fs, parent) when generic_fields fs -> + (match parent with + | Some t -> + fail t.Ast.tloc + "%s is generic, and a condition struct is not — a handler \ + matches one type, and %s is a type only at its arguments" n n + | None -> ()); + Hashtbl.replace env.locs n d.Ast.dloc; + Hashtbl.replace gpending n (fs, d.Ast.dloc) | Ast.Defstruct (n, _, _) -> Hashtbl.replace env.locs n d.Ast.dloc; Hashtbl.replace env.structs n { Tast.sname = n; fields = [] } @@ -12314,6 +13686,26 @@ let collect env (decls : Ast.decl list) = | Ast.Defalias (n, t) -> Hashtbl.replace env.aliases n t | _ -> ()) decls; + (* Each template's parameters, which needs every other template's: a + template's length argument to another is a length of its own. A cycle + between templates reads the arguments on it as types; any length among + them is then refused where it is used. *) + let rec params_of visiting n = + match Hashtbl.find_opt env.gstructs n with + | Some g -> Some (List.map snd g.gparams) + | None -> + match Hashtbl.find_opt gpending n with + | None -> None + | Some _ when List.mem n visiting -> None + | Some (fs, gloc) -> + let _, _, vs = + sigil_vars ~kinds_of:(params_of (n :: visiting)) + (List.map (fun (f : Ast.field) -> f.Ast.fty) fs) + in + Hashtbl.replace env.gstructs n { gparams = vs; gfields = fs; gloc }; + Some (List.map snd vs) + in + Hashtbl.iter (fun n _ -> ignore (params_of [] n)) gpending; (* Compile-time integer constants next, to a fixpoint, because an array length may name a constant declared below it — top-level names in a package are order-independent (plan.org, Modules). *) @@ -12450,6 +13842,22 @@ let collect env (decls : Ast.decl list) = Hashtbl.replace env.externs fn.Ast.name csym; Hashtbl.replace env.extern_locs fn.Ast.name loc | Ast.Defalias _ -> () + | Ast.Defstruct (n, fs, _) when Hashtbl.mem env.gstructs n -> + let names = List.map (fun (f : Ast.field) -> f.Ast.fname) fs in + if List.length (List.sort_uniq compare names) <> List.length names then + fail loc "%s declares the same field twice" n; + (* The template is checked once, here, at its variables: an unknown + type in a field is refused at the defstruct rather than at the + first use of it. *) + let g = Hashtbl.find env.gstructs n in + (match + struct_copy ~at_definition:true env loc n + (List.map (fun (p, _) -> Types.Var p) g.gparams) + with + | _ -> () + | exception Loc.Error d -> + Hashtbl.replace env.broken n (); + defer_or_raise env d) | Ast.Defstruct (n, fs, parent) -> let names = List.map (fun (f : Ast.field) -> f.Ast.fname) fs in if List.length (List.sort_uniq compare names) <> List.length names then @@ -12570,7 +13978,7 @@ let collect env (decls : Ast.decl list) = signature: it goes in [gsigs] and the function goes nowhere near [fns], because nothing can be called at [t]. Every call site turns it into an ordinary entry. *) - let vars = signature_tyvars fn in + let vars, lens = signature_tyvars env fn in (* The [where] clause is checked against the signature here, once, rather than at every use of it: a predicate nobody has heard of, or one about a variable the signature never bound, is a mistake @@ -12588,18 +13996,47 @@ let collect env (decls : Ast.decl list) = (if vars = [] then " — it binds none" else " — it binds " - ^ String.concat ", " (List.map (fun v -> "$" ^ v) vars))) + ^ String.concat ", " (List.map (fun v -> "$" ^ v) vars)); + (* A where clause takes type predicates, and a length is not a + type. Whether it should take value predicates over one is + an open question in TODO.org, not an accident to fall out + of this. *) + if List.mem p.Ast.pvar lens then + defer_or_raise env + (Loc.diag ~kind:"check/length-predicate" p.Ast.ploc + (Printf.sprintf + "$%s is a length, and a where clause takes type \ + predicates only — %s is about a type" + p.Ast.pvar p.Ast.pname))) fn.Ast.fwhere; + (* A predicate over a length was refused above; what is left is the + clause every copy is judged against. *) + let fn = + { fn with + Ast.fwhere = + List.filter + (fun (p : Ast.pred) -> not (List.mem p.Ast.pvar lens)) + fn.Ast.fwhere } + in env.tyvars <- vars; + env.lenvars <- lens; env.tvpreds <- fn.Ast.fwhere; - let params = - List.map (fun (p : Ast.field) -> resolve env p.Ast.fty) fn.Ast.params + let params, ret = + Fun.protect + ~finally:(fun () -> + env.tyvars <- []; env.lenvars <- []; env.tvpreds <- []) + (fun () -> + let params = + List.map (fun (p : Ast.field) -> resolve env p.Ast.fty) + fn.Ast.params + in + let ret = + match fn.Ast.ret with + | None -> Types.Unit + | Some t -> resolve env t + in + params, ret) in - let ret = - match fn.Ast.ret with None -> Types.Unit | Some t -> resolve env t - in - env.tyvars <- []; - env.tvpreds <- []; if fn.Ast.fprivate <> Ast.Exported then Hashtbl.replace env.privates fn.Ast.name (fn.Ast.nloc, fn.Ast.fprivate); @@ -12610,7 +14047,8 @@ let collect env (decls : Ast.decl list) = end else begin Hashtbl.replace env.generics fn.Ast.name fn; - Hashtbl.replace env.gsigs fn.Ast.name (vars, params, ret) + Hashtbl.replace env.gsigs fn.Ast.name (vars, params, ret); + Hashtbl.replace env.glens fn.Ast.name lens end | Ast.Defvar (n, t, _, k) -> let ty = match t with @@ -12657,7 +14095,7 @@ let collect env (decls : Ast.decl list) = let left = List.filter (fun ((n, _) as c) -> - match infer c with + match speculate env (fun () -> infer c) with | ty -> Hashtbl.replace env.globals n (ty, true); false | exception Loc.Error _ -> true) !pending @@ -12681,37 +14119,11 @@ let collect env (decls : Ast.decl list) = it is inline. Caught here rather than when a backend tries to lay the type out or a zero value is built for it — which would not fail, it would hang. *) let check_finite env = - let rec walk seen name = - if List.mem name seen then - fail (Option.value (Hashtbl.find_opt env.locs name) ~default:Loc.unknown) - "%s contains itself by value, so it has no size — go through (Ptr %s)" - name name; - let seen = name :: seen in - match Hashtbl.find_opt env.structs name with - | Some s -> List.iter (fun (f : Tast.field) -> ty seen f.Tast.fty) s.Tast.fields - | None -> - match Hashtbl.find_opt env.datas name with - | Some u -> - List.iter - (fun (c : Tast.variant) -> - List.iter (fun (f : Tast.field) -> ty seen f.Tast.fty) c.Tast.vfields) - u.Tast.cases - | None -> - (* A union whose member is itself is the same infinite type a struct's - is — the size is the largest member and the largest member is the - whole thing. Nothing about overlaying storage makes the recursion - finite, so it is on the same walk rather than left to hang the - layout calculator. *) - match Hashtbl.find_opt env.unions name with - | None -> () - | Some u -> - List.iter (fun (f : Tast.field) -> ty seen f.Tast.fty) u.Tast.fields - and ty seen = function - | Types.Named n -> walk seen n - | Types.Array (_, e) | Types.Option e -> ty seen e - | _ -> () - in - Hashtbl.iter (fun n _ -> walk [] n) env.structs; + let walk _ n = finite_from env n in + (* A generic struct's copy was asked this when it was made. *) + Hashtbl.iter + (fun n _ -> if not (Hashtbl.mem env.copies n) then walk [] n) + env.structs; Hashtbl.iter (fun n _ -> walk [] n) env.datas; Hashtbl.iter (fun n _ -> walk [] n) env.unions @@ -12770,6 +14182,55 @@ let check_union_members env = (* ── Declarations: pass 2, check bodies ────────────────────────────── *) +(* The names a body hands back or stores into: every name mentioned in a value + it answers — its last form's tails, a [return]'s value — and the name at + the root of every [set] place. A parameter among them is not warned at for + growing: the grown copy goes back to the caller, or the copy is the + function's own business. *) +let escaping_names ~returns (body : Ast.expr list) : string list = + let names = ref [] in + let rec mentions (e : Ast.expr) = + (match e.Ast.e with Ast.Var n -> names := n :: !names | _ -> ()); + ignore (Ast.map_children (fun x -> mentions x; x) e) + in + let rec tails (e : Ast.expr) = + match e.Ast.e with + | Ast.Do es | Ast.Let (_, es) -> + (match List.rev es with x :: _ -> tails x | [] -> ()) + | Ast.If (_, a, b) -> tails a; Option.iter tails b + | Ast.Match (_, arms) -> + List.iter + (fun (a : Ast.arm) -> + match List.rev a.Ast.body with x :: _ -> tails x | [] -> ()) + arms + (* A value that is the parameter, a field of it, or a literal built with + it. A call's result is its callee's business, and a unit form — the + push itself, last in a function that returns nothing — answers + nothing. *) + | Ast.Var _ | Ast.Field _ | Ast.Struct _ | Ast.Bare _ | Ast.Arr _ + | Ast.MapLit _ -> mentions e + | _ -> () + in + let rec root (e : Ast.expr) = + match e.Ast.e with + | Ast.Var n -> names := n :: !names + | Ast.Field (x, _) -> root x + | Ast.Call ({ Ast.e = Ast.Var ("at" | "deref"); _ }, x :: _) -> root x + | _ -> () + in + let rec walk (e : Ast.expr) = + (match e.Ast.e with + | Ast.Return (Some x) -> tails x + | Ast.Set (Ast.Pvar n, _) -> names := n :: !names + | Ast.Set ((Ast.Pfield (x, _) | Ast.Pindex (x, _) | Ast.Pderef x + | Ast.Pslot (x, _)), _) -> root x + | _ -> ()); + ignore (Ast.map_children (fun x -> walk x; x) e) + in + List.iter walk body; + if returns then (match List.rev body with x :: _ -> tails x | [] -> ()); + !names + let rec check_fn env (fn : Ast.fn) : Tast.fn = let params, ret = Hashtbl.find env.fns fn.Ast.name in let ctx = { (invented_ctx env ret) with owner = fn.Ast.name } in @@ -12792,6 +14253,41 @@ let rec check_fn env (fn : Ast.fn) : Tast.fn = end; ignore (bind ctx p.Ast.fname ty ~assignable:false)) fn.Ast.params params; + let grow_before = !grow_warnings in + let grow_saved = !grow_params in + grow_params := + ( ctx, + List.filter_map + (fun (p : Ast.field) -> + Option.map (fun b -> (b.slot, p)) (List.assoc_opt p.Ast.fname ctx.scope)) + fn.Ast.params ) + :: grow_saved; + let escaping = + lazy + (let names = + escaping_names ~returns:(not (Types.equal ret Types.Unit)) fn.Ast.fbody + in + List.filter_map + (fun (p : Ast.field) -> + if List.mem p.Ast.fname names then Some p.Ast.floc else None) + fn.Ast.params) + in + Fun.protect + ~finally:(fun () -> + grow_params := grow_saved; + let added = + List.filteri + (fun i _ -> i < List.length !grow_warnings - List.length grow_before) + !grow_warnings + in + if added <> [] then + grow_warnings := + List.filter + (fun (d : Loc.diag) -> + not (List.mem d.Loc.dloc (Lazy.force escaping))) + added + @ grow_before) + @@ fun () -> let body = match fn.Ast.fbody with | [] -> @@ -12891,8 +14387,30 @@ let rec check_fn env (fn : Ast.fn) : Tast.fn = and check_generic env (fn : Ast.fn) = let vars, params, ret = Hashtbl.find env.gsigs fn.Ast.name in let saved_lifted = env.lifted and saved_vars = env.tyvars - and saved_preds = env.tvpreds in + and saved_preds = env.tvpreds and saved_lens = env.lenvars + and saved_ph = env.len_placeholder in + (* The body sees a length variable's array at [abstract_len], an ordinary + array every array operation already answers for; the signature keeps + its [Types.LArray] for call sites to bind against. *) + let rec at_placeholder (t : Types.t) = + match t with + | Types.LArray (_, e) -> Types.Array (abstract_len, at_placeholder e) + | Types.Slice (m, e) -> Types.Slice (m, at_placeholder e) + | Types.Array (n, e) -> Types.Array (n, at_placeholder e) + | Types.Ptr (m, e) -> Types.Ptr (m, at_placeholder e) + | Types.Vec e -> Types.Vec (at_placeholder e) + | Types.Option e -> Types.Option (at_placeholder e) + | Types.Map (k, v) -> Types.Map (at_placeholder k, at_placeholder v) + | Types.Fn (ps, r) -> Types.Fn (List.map at_placeholder ps, at_placeholder r) + | Types.CFn (ps, r) -> + Types.CFn (List.map at_placeholder ps, at_placeholder r) + | t -> t + in + let params = List.map at_placeholder params and ret = at_placeholder ret in env.tyvars <- vars; + env.lenvars <- + Option.value (Hashtbl.find_opt env.glens fn.Ast.name) ~default:[]; + env.len_placeholder <- true; (* What the abstract pass may assume. Every operator the body reaches asks [env.tvpreds] whether the variable was declared to support it, and every instantiation asks the concrete type the same question again. *) @@ -12902,7 +14420,9 @@ and check_generic env (fn : Ast.fn) = Hashtbl.remove env.fns fn.Ast.name; env.lifted <- saved_lifted; env.tyvars <- saved_vars; - env.tvpreds <- saved_preds + env.tvpreds <- saved_preds; + env.lenvars <- saved_lens; + env.len_placeholder <- saved_ph in (match check_fn env fn with | _ -> finish () @@ -13912,30 +15432,37 @@ let shown_name n = else n let shadow_prelude (prelude : Ast.decl list) (decls : Ast.decl list) = - let fn_name (d : Ast.decl) = + (* A value name, and whether it is a function's. A program's global takes + a prelude function's name over as a program's function does: both are + names a call or a read reaches, and the prelude's own uses keep the + prelude's. *) + let value_name (d : Ast.decl) = match d.Ast.d with - | Ast.Defn fn | Ast.Declare (fn, _) | Ast.DeclareC (fn, _) -> Some fn.Ast.name + | Ast.Defn fn | Ast.Declare (fn, _) | Ast.DeclareC (fn, _) -> + Some (fn.Ast.name, true) + | Ast.Defvar (n, _, _, _) | Ast.Defconst (n, _, _) -> Some (n, false) | _ -> None in - let theirs = List.filter_map fn_name prelude in + let theirs = List.map fst (List.filter_map value_name prelude) in let taken = List.filter_map (fun (d : Ast.decl) -> - match fn_name d with - | Some n when List.mem n theirs -> Some (n, d.Ast.dloc) + match value_name d with + | Some (n, f) when List.mem n theirs -> Some (n, d.Ast.dloc, f) | _ -> None) decls in let warnings = List.map - (fun (n, at) -> + (fun (n, at, f) -> Loc.diag ~kind:"check/shadows-prelude" at (Printf.sprintf - "%s shadows the prelude's %s — every call in this file now \ + "%s shadows the prelude's %s — every %s in this file now \ reaches your definition" - n n)) + n n (if f then "call" else "use"))) taken in + let taken = List.map (fun (n, at, _) -> (n, at)) taken in let prelude, decls = List.fold_left (fun (prelude, decls) (n, (at : Loc.t)) -> @@ -13981,7 +15508,7 @@ let build_program ~keep_going ?tolerate (decls : Ast.decl list) : in (match f () with | x -> x - | exception (Loc.Error d as e) -> + | exception ((Loc.Error d | Loc.Errors (d :: _)) as e) -> if ok env name d then begin Hashtbl.filter_map_inplace (fun g r -> @@ -14042,10 +15569,21 @@ let build_program ~keep_going ?tolerate (decls : Ast.decl list) : time it runs every signature is sound, so a body that fails to check cannot make the next body fail — which is what makes a declaration a resync point that needs no resynchronising. *) + if keep_going then env.deferred <- Some []; + grow_warnings := []; let decls = collect env decls in + if !print_warnings then + List.iter + (fun (d : Loc.diag) -> + prerr_endline + (Loc.entry ~mark:'~' ~label:"warning: " d.Loc.dloc d.Loc.dmsg)) + (List.rev !pairing_warnings); check_finite env; check_union_members env; let s = Loc.sink ~on:keep_going in + (match env.deferred with + | Some ds -> s.Loc.found <- ds; env.deferred <- None + | None -> ()); ignore (Loc.caught s (fun () -> check_main env decls)); (* Every generic body, checked once with its variables left abstract, and the result thrown away. This is the pass plan.org's rule needs and Odin @@ -14060,9 +15598,14 @@ let build_program ~keep_going ?tolerate (decls : Ast.decl list) : (fun (d : Ast.decl) -> match d.Ast.d with | Ast.Defn fn when Hashtbl.mem env.gsigs fn.Ast.name -> - ignore - (Loc.caught s (fun () -> - tolerant fn.Ast.name (fun () -> Some (check_generic env fn)))) + (match + Loc.caught s (fun () -> + tolerant fn.Ast.name (fun () -> + with_recovery env ~on:keep_going (fun () -> + Some (check_generic env fn)))) + with + | None -> Hashtbl.replace env.refused_generics fn.Ast.name () + | Some _ -> ()) | _ -> ()) decls; let globals = @@ -14070,9 +15613,12 @@ let build_program ~keep_going ?tolerate (decls : Ast.decl list) : (fun (d : Ast.decl) -> Option.join (Loc.caught s (fun () -> + let checked () = + with_recovery env ~on:keep_going (fun () -> check_global env d) + in match Ast.declared_name d with - | Some n -> tolerant n (fun () -> check_global env d) - | None -> check_global env d))) + | Some n -> tolerant n checked + | None -> checked ()))) decls in let fns = @@ -14085,10 +15631,18 @@ let build_program ~keep_going ?tolerate (decls : Ast.decl list) : | Ast.Defn fn -> Option.join (Loc.caught s (fun () -> - tolerant fn.Ast.name (fun () -> Some (check_fn env fn)))) + tolerant fn.Ast.name (fun () -> + with_recovery env ~on:keep_going (fun () -> + Some (check_fn env fn))))) | _ -> None) decls in + if !print_warnings then + List.iter + (fun (d : Loc.diag) -> + prerr_endline + (Loc.entry ~mark:'~' ~label:"warning: " d.Loc.dloc d.Loc.dmsg)) + (List.rev !grow_warnings); Loc.finish s; (* The handler clauses lifted out along the way. They are ordinary functions from here down; nothing in the backend knows they were written inside @@ -14124,7 +15678,12 @@ let build_program ~keep_going ?tolerate (decls : Ast.decl list) : |> List.sort (fun (a : Tast.extern) b -> String.compare a.Tast.esym b.Tast.esym) in let p = - { Tast.structs = values (fun (s : Tast.structure) -> s.Tast.sname) env.structs; + { Tast.structs = + (* A struct copy at variables was only ever for an abstract pass. *) + List.filter + (fun (s : Tast.structure) -> + Hashtbl.find_opt env.copies s.Tast.sname <> Some true) + (values (fun (s : Tast.structure) -> s.Tast.sname) env.structs); datas = values (fun (u : Tast.data) -> u.Tast.dname) env.datas; unions = values (fun (u : Tast.structure) -> u.Tast.sname) env.unions; globals; externs; fns; cshim } @@ -14144,8 +15703,8 @@ let program_with_env (decls : Ast.decl list) : Tast.program * env = (** The same, with [tolerate] deciding which body failures leave a declaration out rather than refuse it — see [build_program]. The names left out come back beside the program; nothing else about it changes. *) -let program_tolerant ~tolerate (decls : Ast.decl list) = - build_program ~keep_going:false ~tolerate decls +let program_tolerant ?(keep_going = false) ~tolerate (decls : Ast.decl list) = + build_program ~keep_going ~tolerate decls let program (decls : Ast.decl list) : Tast.program = let p, _, _ = build_program ~keep_going:false decls in @@ -14216,6 +15775,24 @@ let lifted_since env mark = let fresh = List.length env.lifted - mark in List.rev (List.filteri (fun i _ -> i < fresh) env.lifted) +(* The struct copies this env made that [have] does not hold: what an + expression checked against a running session named for the first time — + [(Pair 1 2)] typed at a REPL makes [(Pair i32)] — which the module built + for it has to lay out, and the session has to keep. *) +let fresh_copies env (have : Tast.structure list) = + Hashtbl.fold + (fun k at_vars acc -> + if at_vars + || List.exists (fun (s : Tast.structure) -> String.equal s.Tast.sname k) + have + then acc + else + match Hashtbl.find_opt env.structs k with + | Some s -> s :: acc + | None -> acc) + env.copies [] + |> List.sort (fun (a : Tast.structure) b -> String.compare a.Tast.sname b.Tast.sname) + let env_structs env (fns : Tast.fn list) = List.filter_map (fun (f : Tast.fn) -> Hashtbl.find_opt env.structs ("env/" ^ f.Tast.name)) @@ -14263,6 +15840,25 @@ let expressions env (es : (Types.t option * Ast.expr) list) : (ts, Array.of_list (List.rev ctx.slot_tys), Array.of_list (List.rev ctx.slot_names)) +(* One expression checked with [scope]'s names already bound, in order, so a + later entry shadows an earlier one of the same name: evaluating in a stopped + frame, whose locals the expression may name. Each is bound to a slot of the + expression's own frame, and which slot is answered beside the name, so the + caller can point every use of it at the stopped frame's storage instead + ([Tast.rewrite_locals]). *) +let expression_in_scope env ~(scope : (string * Types.t * bool) list) + (e : Ast.expr) : + Tast.expr * Types.t array * string option array * (string * int) list = + let ctx = invented_ctx env Types.Unit in + let bound = + List.map + (fun (name, ty, assignable) -> (name, bind ctx name ty ~assignable)) + scope + in + let t = expect ctx e.Ast.loc ~want:None (check ctx e) in + (t, Array.of_list (List.rev ctx.slot_tys), + Array.of_list (List.rev ctx.slot_names), bound) + (* The one-expression case, which is every caller but the write verb. *) let expression env ?want (e : Ast.expr) : Tast.expr * Types.t array * string option array = diff --git a/lib/cimport.ml b/lib/cimport.ml index 9fea9ebe..266879f5 100644 --- a/lib/cimport.ml +++ b/lib/cimport.ml @@ -407,6 +407,7 @@ let rec ty_source (t : Ast.texpr) = | Ast.Tname n -> n | Ast.Tapp (n, args) -> Printf.sprintf "(%s %s)" n (String.concat " " (List.map ty_source args)) + | Ast.Tlen n -> Int64.to_string n | Ast.Tslice (c, e) -> Printf.sprintf "[%s%s]" (if c then "const " else "") (ty_source e) | Ast.Tarray (Ast.Lint n, e) -> Printf.sprintf "[%Ld %s]" n (ty_source e) diff --git a/lib/dev.ml b/lib/dev.ml index f51ad7ac..8c0b8967 100644 --- a/lib/dev.ml +++ b/lib/dev.ml @@ -28,11 +28,15 @@ type t = { (* The running program. [Some pid] is the two-process daemon, which launched it; [None] is the merged build, where the program is *this* process and the compiler is a thread inside it. That is the whole of the difference at - this layer — see [merged_setup] for why there is no third case. *) - child : int option; + this layer — see [merged_setup] for why there is no third case. A re-run + under --two-process replaces the child with a new one. *) + mutable child : int option; agent : string; (* where it listens for modules *) dir : string; (* modules are built here, one per eval *) - stdout : Unix.file_descr; (* the program's output, on its way to here *) + mutable stdout : Unix.file_descr; (* the program's output, on its way here *) + (* --two-process only: build the program again from the session as it is + now and start it, answering the new child and its stdout. *) + relaunch : (unit -> int * Unix.file_descr) option; out : Buffer.t; (* ...buffered until an editor asks for it *) mutable n : int; (* dlopen caches by path: never reuse one *) (* Bookkeeping for disassembly, and the reason it can exist at all: the @@ -268,10 +272,41 @@ let deliver_at_stop t ~gen path = [None] where the program cannot be reached or answers something else, and the caller treats that the way it treats a missing refusal count: as no evidence, not as zero. Zero is a fact — it means running. *) -let stop_gen t : int option = +let stop_reply t = match request t "stop" with | exception Unix.Unix_error _ -> None - | text -> int_of_string_opt (String.trim text) + | text -> + (match String.split_on_char ' ' (String.trim text) with + | g :: rest -> + Option.map (fun g -> (g, rest)) (int_of_string_opt g) + | [] -> None) + +let stop_gen t : int option = Option.map fst (stop_reply t) + +(* How many evaluated expressions the agent has queued, and the highest one + that has returned a value; [None] from an agent without the verb. *) +let calls t : (int * int) option = + match request t "calls" with + | exception Unix.Unix_error _ -> None + | text -> + (match String.split_on_char ' ' (String.trim text) with + | [ q; v ] -> + (match int_of_string_opt q, int_of_string_opt v with + | Some q, Some v -> Some (q, v) + | _ -> None) + | _ -> None) + +(* The same stop with whose code it stopped in: [Some true] when the thread + was running an evaluated thunk, [Some false] when it was in the program's + own code, [None] from an agent that does not say. *) +let stop_owner t : (int * bool option) option = + Option.map + (fun (g, rest) -> + (g, match rest with + | [ "eval" ] -> Some true + | [ "program" ] -> Some false + | _ -> None)) + (stop_reply t) (* How many stopped-only modules the program has thrown away for reaching the game thread while it was running, and the sentence the agent says about it. @@ -669,14 +704,12 @@ let host_loc t name = that was written finds nothing in the program, and these are how it gets from that name to what the program does hold. *) -(* Its signature as written, [$] and all — [Types.to_string] prints a variable - bare, and [[t]] is not how anyone wrote it. *) +(* Its signature as written, [$] and all. *) let generic_signature t name = match Hashtbl.find_opt t.session.Session.env.Check.gsigs name with | None -> None - | Some (vars, params, ret) -> - let dollar = List.map (fun v -> (v, Types.Var ("$" ^ v))) vars in - let show ty = Types.to_string (Check.subst_ty dollar ty) in + | Some (_, params, ret) -> + let show ty = Types.to_string ty in Some (Printf.sprintf "%s [%s] %s" name (String.concat " " (List.map show params)) (show ret)) @@ -804,7 +837,8 @@ let build_module (c : Session.change) ~debug ~out = spelled once so that every op tells the same story. [gone] is what all of them used to say and is now said only where it is - true: there is no process left and nothing short of a new one will help. + true: there is no process left and nothing short of a new one will help — + which, under --two-process, a re-run is. [parked] is the new half, and the sentence it appends is the whole point of the distinction. Somebody reading it has a program that is *there* — its @@ -815,7 +849,7 @@ let build_module (c : Session.change) ~debug ~out = refused for want of a frame boundary and an op refused for want of a stopped stack are refused by the same state for different causes, and a reader who cannot tell them apart cannot tell what to do instead. *) -let gone = "the program exited; restart flan dev" +let gone = "the program exited; M-x flan-rerun starts it again" let parked_msg why = why @@ -997,7 +1031,32 @@ let stale_field (ss : Session.stale list) = (if x.Session.running then " :running t" else "")) ss) ] -let eval ?forms ?base ?(extra = []) t ~code ~origin ~pause = +(* Every refusal a check found, one plist each: beside what a load installed, + or beside the first of them when a form sent had several. *) +let errors_field (ds : Loc.diag list) = + match ds with + | [] -> [] + | ds -> + [ ":errors " + ^ Wire.list + (List.map + (fun (d : Loc.diag) -> + Printf.sprintf "(:loc %s :message %s)" + (Wire.quote (Loc.to_string d.Loc.dloc)) + (Wire.quote d.Loc.dmsg)) + ds) ] + +(* A refusal with several diagnostics: the first where every refusal puts its + message, all of them under [:errors]. *) +let errors_reply (ds : Loc.diag list) = + match ds with + | [] -> error "nothing was refused" + | d :: _ -> + let e = error ~loc:(Loc.to_string d.Loc.dloc) d.Loc.dmsg in + String.sub e 0 (String.length e - 1) + ^ " " ^ String.concat " " (errors_field ds) ^ ")" + +let eval ?forms ?base ?(extra = []) ?(step = false) t ~code ~origin ~pause = let now = liveness t in let parked_now = now = Parked in (* A park that is over takes its note with it: the long sentence below is @@ -1018,10 +1077,28 @@ let eval ?forms ?base ?(extra = []) t ~code ~origin ~pause = nothing that can go wrong after it. *) let before = Session.held t.session in let refused msg = Session.restore t.session before; error msg in - if now = Gone then error gone + if now = Gone && t.relaunch <> None then + (* --two-process, the child ended: the form is checked into the session + and nothing is sent, because the next process is built from the + session whole ([rerun]). *) + match + Session.eval ~origin ?base ?forms ?pause ~running:false t.session code + with + | c -> + ok + ([ ":names " ^ Wire.strings c.Session.names; ":fns ()"; + ":note " + ^ Wire.quote + "loaded; the program has ended, so this is in it when M-x \ + flan-rerun starts it again" ] + @ extra) + | exception Loc.Error { Loc.dloc = l; dmsg = msg; _ } -> + Session.restore t.session before; + error ~loc:(Loc.to_string l) msg + else if now = Gone then error gone else match - Session.eval ~origin ?base ?forms ?pause ~running:(not parked_now) + Session.eval ~origin ?base ?forms ?pause ~step ~running:(not parked_now) t.session code with | c when not c.Session.installs -> @@ -1084,6 +1161,7 @@ let eval ?forms ?base ?(extra = []) t ~code ~origin ~pause = | Some (l, c) -> [ ":pause " ^ Wire.quote (Printf.sprintf "%d:%d" l c) ] | None -> []) + @ (if step then [ ":step t" ] else []) @ install_note t ~parked:parked_now @ unpolled_note t ~parked:parked_now @ extra) @@ -1102,20 +1180,9 @@ let eval ?forms ?base ?(extra = []) t ~code ~origin ~pause = | exception Loc.Error { Loc.dloc = l; dmsg = msg; _ } -> Session.restore t.session before; error ~loc:(Loc.to_string l) msg - -(* The refusals a load answered beside what it installed, one plist each. *) -let errors_field (ds : Loc.diag list) = - match ds with - | [] -> [] - | ds -> - [ ":errors " - ^ Wire.list - (List.map - (fun (d : Loc.diag) -> - Printf.sprintf "(:loc %s :message %s)" - (Wire.quote (Loc.to_string d.Loc.dloc)) - (Wire.quote d.Loc.dmsg)) - ds) ] + | exception Loc.Errors ds -> + Session.restore t.session before; + errors_reply ds (* C-c C-k: a whole file into the running session, SBCL's [load]. [eval] with one difference — a form that does not compile is left out and listed @@ -1143,16 +1210,9 @@ let load_file t ~code ~origin = (match Session.pruned check forms with | exception Loc.Error { Loc.dloc = l; dmsg = msg; _ } -> error ~loc:(Loc.to_string l) msg - | exception Loc.Errors ({ Loc.dloc = l; dmsg = msg; _ } :: _ as ds) -> - let e = error ~loc:(Loc.to_string l) msg in - String.sub e 0 (String.length e - 1) - ^ " " ^ String.concat " " (errors_field ds) ^ ")" + | exception Loc.Errors ds -> errors_reply ds | (), kept, errs -> - if errs <> [] && kept = [] then - let d = List.hd errs in - let e = error ~loc:(Loc.to_string d.Loc.dloc) d.Loc.dmsg in - String.sub e 0 (String.length e - 1) - ^ " " ^ String.concat " " (errors_field errs) ^ ")" + if errs <> [] && kept = [] then errors_reply errs else eval ~forms:kept ?base ~extra:(errors_field errs) t ~code ~origin ~pause:None) @@ -1193,7 +1253,7 @@ let load_file t ~code ~origin = state to spawn it beside; the price is that eval races the application and the race is documented as the programmer's problem. There is no race to document here, because there is nothing running to race. *) -let eval_expr t ~code ~origin ~pause = +let eval_expr_at t ~code ~origin ~pause ~at = match liveness t with | Gone -> error gone | Live | Parked -> @@ -1209,9 +1269,13 @@ let eval_expr t ~code ~origin ~pause = let had = List.map (fun (f : Tast.fn) -> f.Tast.name) t.session.Session.program.Tast.fns in - match Session.eval_expr ~origin ~pause t.session code with + match Session.eval_expr ~origin ~pause ?frame:(Option.map snd at) t.session code with | c -> let before = match result t with Some (g, _) -> g | None -> 0L in + (* This expression's number among those the agent has queued: an + earlier one resumed by a restart can publish after this one is sent, + and the result counter alone would take its value for this one's. *) + let mine = Option.map (fun (q, _) -> q + 1) (calls t) in (* Read here, beside [before], and for the same kind of reason: all three are the "how things stood" half of a difference the wait below measures. A program already sitting in a break when the request @@ -1225,19 +1289,23 @@ let eval_expr t ~code ~origin ~pause = the reason [stop_gen]'s note gives at its definition. The name is kept beside it as the fallback for an agent that cannot answer the verb. - As early as it usefully can be, and still not early enough to be - exact: [build_module] below takes a couple of hundred milliseconds, - and a game loop that signals *on its own* during them — or mid-wait, - while the thunk is still perfectly fine — bumps the generation too. - The reply then says "the expression stopped on X" about an expression - that had not run. Its machine-readable half stays right, so the editor - opens the break the program is actually in; only the sentence is - wrong, and no counter closes this one, because the program's break and - the thunk's are the same kind of event. Separating them wants the - per-frame origin the backtrace carries, which is LLVM-only. - TODO.org, "Whose break it is, which no counter answers" has it. *) + A game loop that signals *on its own* while this is in flight bumps + the generation too, so a fresh stop is not yet the thunk's. The stop + itself says whose it is — see [settled] below. *) let entered = state t in let entered_gen = stop_gen t in + (* In a frame the thunk is addressed to one stop, and the agent drops it, + and counts the drop, if that stop has ended by the time it is + claimed. Read before the build, which is when that usually happens. *) + let refused_before = if at = None then None else refusals t in + let dropped () = + match refused_before with + | None -> None + | Some (before, _) -> + (match refusals t with + | Some (now, why) when now > before -> Some why + | _ -> None) + in t.n <- t.n + 1; let out = Filename.concat t.dir (Printf.sprintf "e%d.so" t.n) in (* A generic called at a new type makes a copy that is defined in this @@ -1256,7 +1324,14 @@ let eval_expr t ~code ~origin ~pause = in (match build_module c ~debug:t.session.Session.debug ~out with | _ -> - (match deliver t out with + (match + (* In a frame, only at the stop the frame was read at: the thunk + reads that frame's slots by address, and after a resume they + are somebody else's storage. *) + match at with + | Some (gen, _) -> deliver_at_stop t ~gen out + | None -> deliver t out + with | "ok" -> if copies <> [] then begin t.gen <- t.gen + 1; @@ -1323,12 +1398,17 @@ let eval_expr t ~code ~origin ~pause = re-stop between them could pair a stale name with a fresh generation; it cannot manufacture one, since the generation only climbs when a break really was entered. *) + (* A fresh stop in the program's own code is not an answer: the + thunk has not run, and the break loop that stop entered polls + the ring, so the thunk runs inside it and its value arrives on + a later tick. *) let settled now = match now with | Stopped c -> let fresh = - match stop_gen t, entered_gen with - | Some g, Some g0 -> g > g0 + match stop_owner t, entered_gen with + | Some (_, Some false), _ -> false + | Some (g, _), Some g0 -> g > g0 | _ -> (match entered with Stopped c0 -> c0 <> c | _ -> true) in @@ -1368,9 +1448,16 @@ let eval_expr t ~code ~origin ~pause = the sleep has to stay a sleep. *) drain t; let value () = - match result t with - | Some (g, v) when Int64.compare g before > 0 -> Some v - | _ -> None + let returned = + match mine, calls t with + | Some m, Some (_, v) -> v >= m + | _ -> true + in + if not returned then None + else + match result t with + | Some (g, v) when Int64.compare g before > 0 -> Some v + | _ -> None in match value () with | Some v -> `Value v @@ -1402,6 +1489,9 @@ let eval_expr t ~code ~origin ~pause = | Some answer -> (match value () with Some v -> `Value v | None -> answer) | None -> + match dropped () with + | Some why -> `Dropped why + | None -> if ms <= 0 then `Timeout else begin ignore (Unix.select [] [] [] 0.005); @@ -1466,6 +1556,7 @@ let eval_expr t ~code ~origin ~pause = left over, which is the shape it was always about: a program that is running, is not parked, and produced nothing in five seconds. *) + | `Dropped why -> error why | `Timeout -> if liveness t = Parked then error @@ -1821,8 +1912,27 @@ let defs t = ~loc:(Loc.to_string loc) ()) classes in + (* A generic struct is listed by its template, as [(Pair $t)]; its copies + are struct names only the compiler wrote. *) + let structs = + Hashtbl.fold + (fun name _ acc -> + if Hashtbl.mem env.Check.copies name then acc + else entry ~name ~kind:"struct" ~sign:name ~loc:"" () :: acc) + env.Check.structs [] + @ Hashtbl.fold + (fun name (g : Check.gstruct) acc -> + entry ~name ~kind:"struct" + ~sign: + (Printf.sprintf "(%s %s)" name + (String.concat " " + (List.map (fun (p, _) -> "$" ^ p) g.Check.gparams))) + ~loc:"" () + :: acc) + env.Check.gstructs [] + in List.sort compare - (of_table "struct" env.Check.structs + (structs @ datas @ classes @ of_table "union" env.Check.unions @ of_table "enum" env.Check.enums @@ -1903,13 +2013,19 @@ let defs t = text about the type and never touches the program. *) let layout t ~ty = let structs = t.session.Session.program.Tast.structs in + (* A generic struct's copy answers to the spelling a printed value's head + gives it, [Pair i32], and to its type's, [(Pair i32)], as well as to its + key. *) + let names (s : Tast.structure) = + [ s.Tast.sname; Types.struct_head s.Tast.sname; + Types.to_string (Types.Named s.Tast.sname) ] + in match - List.find_opt (fun (s : Tast.structure) -> String.equal s.Tast.sname ty) - structs + List.find_opt (fun (s : Tast.structure) -> List.mem ty (names s)) structs with | Some s -> ok - [ ":type " ^ Wire.quote s.Tast.sname; + [ ":type " ^ Wire.quote (Types.to_string (Types.Named s.Tast.sname)); ":fields " ^ Wire.list (List.map @@ -2406,6 +2522,40 @@ let stopped_frame t ~frame ~what : (string * Tast.fn, string) result = name name) else Ok (name, fn))) +(* [:frame N] on [eval-expr] is SLIME's eval-in-frame: the expression sees + that stopped frame's locals — see [Session.in_frame]. The frame is checked + the way [locals] and [inspect] check it, and the thunk is delivered at this + stop only. *) +let eval_expr ?frame ?at_stop t ~code ~origin ~pause = + match frame with + | None -> eval_expr_at t ~code ~origin ~pause ~at:None + | Some index -> + (match stopped_frame t ~frame:index ~what:"an expression in a frame" with + | Error m -> error m + | Ok (_, fn) -> + (match stop_gen t with + | None | Some 0 -> + error + "the program resumed while this was being asked; there is no frame \ + to evaluate in any more" + | Some gen -> + (* A frame with no slots has no locals to bind, and the program + has no table to answer for it: the expression sees globals. *) + let bound = + if Array.length fn.Tast.slots = 0 then Ok [] + else bound_slots t ~frame:index + in + (* [at_stop] is the stop the editor drew the frame at. It is not + checked here: the agent refuses a thunk addressed to a stop that + is over, and says so. *) + let gen = Option.value ~default:gen at_stop in + (match bound with + | Error m -> + error ("the program refused to say which slots are bound: " ^ m) + | Ok bound -> + eval_expr_at t ~code ~origin ~pause + ~at:(Some (gen, (index, fn, bound)))))) + (* [(:op "locals" :frame N)] — what a stopped frame's named locals hold. The half of a break loop that the author actually wanted, and the reason @@ -3643,7 +3793,54 @@ let abort t = park, the next request went out while the first run had not started, and the pair of them produced one run — or, a moment later, a refusal saying the program was already running. Both faces are gone with the lag. *) +(* Under --two-process a finished child is gone and there is no thread to + wake, so a re-run is a new process: the program is built again from the + session as it stands, which puts every accepted redefinition in it from + the start, and its globals start over. *) +let relaunch_child t relaunch = + match liveness t with + | Live | Parked -> + error + (if parked_break t then + "the program is stopped at a break, so it cannot be started again \ + until that ends: resume it or abort it" + else + "the program is still running; a re-run starts it again in a new \ + process once this one has finished. Close its window, or let it \ + finish, and ask again") + | Gone -> + (* The whole program is checked again first ([Session.rehost]); a caller + left compiled against a signature that has since changed is where + that fails. *) + let refused (d : Loc.diag) = + error ~loc:(Loc.to_string d.Loc.dloc) + ("a re-run builds the whole program again, and it does not compile: " + ^ d.Loc.dmsg ^ ". Fix this and load it with C-c C-c, then ask again") + in + (match relaunch () with + | child, rd -> + drain t; + (try Unix.close t.stdout with Unix.Unix_error _ -> ()); + t.stdout <- rd; + t.child <- Some child; + t.finished <- false; + t.died <- None; + (* Every body is in the new host now, so no module owns one. *) + Hashtbl.reset t.owners; + ok + [ ":note " + ^ Wire.quote + "started the program again in a new process, built with every \ + change loaded so far; its globals start over, because the \ + process is new" ] + | exception Failure m -> error m + | exception Loc.Error d -> refused d + | exception Loc.Errors (d :: _) -> refused d) + let rerun t = + match t.relaunch with + | Some relaunch -> relaunch_child t relaunch + | None -> match liveness t with | Gone -> error gone (* A file started with no [main] runs a stub that returns at once; running @@ -4382,7 +4579,13 @@ and handle_op t req = let origin = match Wire.string_field req "file" with Some f -> f | None -> "" in - eval t ~code ~origin ~pause:(Wire.pos_field req "pause") + (* [:step t] instruments every defn sent for the stepper. *) + let step = + match Wire.field req "step" with + | Some { Form.v = Form.Sym "nil"; _ } | None -> false + | Some _ -> true + in + eval t ~code ~origin ~pause:(Wire.pos_field req "pause") ~step | None -> error "eval needs :code") | Some "eval-expr" -> (match Wire.string_field req "code" with @@ -4400,7 +4603,8 @@ and handle_op t req = | Some { Form.v = Form.Sym "nil"; _ } | None -> false | Some _ -> true in - eval_expr t ~code ~origin ~pause + eval_expr ?frame:(Wire.int_field req "frame") + ?at_stop:(Wire.int_field req "at-stop") t ~code ~origin ~pause | None -> error "eval-expr needs :code") (* [:all], absent or [nil] being false and anything else true — the spelling [:pause], [:on] and [:reset] already use. One step is the default because @@ -5063,8 +5267,11 @@ let accept_loop ?grace t ls = where a session with no editor attached spends its time. *) agent_check t; match liveness t with - | Gone -> () - | (Live | Parked) as live -> + | Gone when t.relaunch = None -> () + | live -> + (* A --two-process child that has ended can be started again, so the + session waits as a parked one does, on the parked grace. *) + let live = if live = Gone then Parked else live in let idle = Unix.gettimeofday () -. !since in if orphaned ~grace ~served:!served ~idle live then (* The measured gap and not the threshold it crossed: the threshold is @@ -5077,7 +5284,10 @@ let accept_loop ?grace t ls = else (* The program's pipe is in the same select as the listening socket: it has to be drained whether or not an editor is asking for anything. *) - match Unix.select [ ls; t.stdout ] [] [] 0.2 with + (* Not once it has read EOF: an ended child's pipe is readable for + ever, and the loop would spin on it. *) + let fds = if t.finished then [ ls ] else [ ls; t.stdout ] in + match Unix.select fds [] [] 0.2 with | [], _, _ -> go () | ready, _, _ when not (List.mem ls ready) -> drain t; go () | _ -> @@ -5185,19 +5395,21 @@ let need_main ~file (session : Session.t) = (* The agent's C, in every program [flan dev] builds, whether or not the source imports the package: its constructor binds the socket before [main], so a - file that never mentions the agent can still be reached from the editor. A - program that imports it already has it, and is left alone — two copies - would collide at the link. A release build is not built here and is not - affected. *) + file that never mentions the agent can still be reached from the editor. + + Always this compiler's own copy, in place of any the program vendors. The + agent is the daemon's other half — the stack it snapshots and the verbs it + answers are what this file reads — and a program outside this repository + carries whatever copy of vendor/agent it was given, however old. An old one + builds and answers, and then puts every frame at its function's own line, + because it predates the call-site record, so the stepper never moves. One + copy and not two: two would collide at the link. A release build is not + built here. *) let with_agent ~dir csrcs lflags = + let c = Filename.concat dir "flan_agent.c" in + write_file c Runtime_src.agent_source; let csrcs = - if List.exists (fun c -> Filename.basename c = "flan_agent.c") csrcs then - csrcs - else begin - let c = Filename.concat dir "flan_agent.c" in - write_file c Runtime_src.agent_source; - csrcs @ [ c ] - end + List.filter (fun x -> Filename.basename x <> "flan_agent.c") csrcs @ [ c ] in let lflags = lflags @@ -5225,7 +5437,7 @@ let report_dropped ~file = function deletes it — and silently making every reloaded body -O0 would change the frame time of the one function you are iterating on, in the loop whose whole point is watching that number. *) -let two_process ?(debug = false) ?(x86 = true) ~file ~sock () = +let two_process ?(debug = false) ?(sanitize = false) ?(x86 = true) ~file ~sock () = let t0 = Unix.gettimeofday () in (* Absolute, because every location this daemon ever reports is derived from it and an editor is not in this process's working directory. [flan dev @@ -5252,19 +5464,22 @@ let two_process ?(debug = false) ?(x86 = true) ~file ~sock () = against each module as it loads either way, but a breakpoint set on a line in the .flan buffer needs a line table on both sides — the host's to fire before the first C-c C-c, the module's to follow the reload. *) - let _, kept = - Build.executable - ~opts:{ Build.default with Build.dev = true; Build.keep = true; - Build.debug; Build.x86 } - ~csrcs ~lflags session.Session.host ~out:exe - in (* Host and modules are chosen together, which is the whole licence: an [--x86] host gets [--x86] modules because one flag set both, and the source [Build.executable] kept is assembly rather than IR. *) let host_ll = Filename.concat dir (if x86 then "host.s" else "host.ll") in - (match kept with - | Some src -> (try Sys.rename src host_ll with Sys_error _ -> ()) - | None -> ()); + let build_host () = + let _, kept = + Build.executable + ~opts:{ Build.default with Build.dev = true; Build.keep = true; + Build.debug; Build.sanitize; Build.x86 } + ~csrcs ~lflags session.Session.host ~out:exe + in + match kept with + | Some src -> (try Sys.rename src host_ll with Sys_error _ -> ()) + | None -> () + in + build_host (); let agent = Filename.concat dir "agent.sock" in (* The program's source names some socket path; the daemon is the one that @@ -5272,6 +5487,10 @@ let two_process ?(debug = false) ?(x86 = true) ~file ~sock () = environment. Guessing instead would fail silently — everything compiles, the module is built, and nothing ever receives it. *) Unix.putenv "FLAN_AGENT_SOCKET" agent; + (* The child binds that path only if this pid is its parent, so a process + that merely inherited the variable leaves the socket alone + (flan_agent.c, [daemon_socket]). *) + Unix.putenv "FLAN_AGENT_OWNER" (string_of_int (Unix.getpid ())); (* And who its parent is, which is the child's licence to end itself. vendor/agent/flan_agent.c carries the argument at length; the half that belongs here is that this daemon is the only thing that ever kills its @@ -5296,23 +5515,39 @@ let two_process ?(debug = false) ?(x86 = true) ~file ~sock () = the pipe it was writing to; that also meant the pipe could never reach EOF while the child lived, so "wait for EOF on the daemon's end" was never the mechanism it looked like it could be. *) - let rd, wr = Unix.pipe ~cloexec:true () in - let child = Unix.create_process exe [| exe |] Unix.stdin wr Unix.stderr in - Unix.close wr; - Unix.set_nonblock rd; - - (* Wait for it to bind before accepting an evaluation. One that arrives first - would fail for a reason that reads like a compiler bug. *) - if not (await (fun () -> Sys.file_exists agent)) then begin - (try Unix.kill child Sys.sigterm with Unix.Unix_error _ -> ()); - failwith - ("the program did not open its agent socket at " ^ agent - ^ ". Under --two-process every edit reaches the program through that \ - socket.") - end; + let spawn () = + (* A socket file a previous child left behind would answer the wait below + before this child has bound anything. *) + (try Unix.unlink agent with Unix.Unix_error _ -> ()); + let rd, wr = Unix.pipe ~cloexec:true () in + let child = Unix.create_process exe [| exe |] Unix.stdin wr Unix.stderr in + Unix.close wr; + Unix.set_nonblock rd; + (* Wait for it to bind before accepting an evaluation. One that arrives + first would fail for a reason that reads like a compiler bug. *) + if not (await (fun () -> Sys.file_exists agent)) then begin + (try Unix.kill child Sys.sigterm with Unix.Unix_error _ -> ()); + (try Unix.close rd with Unix.Unix_error _ -> ()); + failwith + ("the program did not open its agent socket at " ^ agent + ^ ". Under --two-process every edit reaches the program through that \ + socket.") + end; + (child, rd) + in + let child, rd = spawn () in + (* A re-run: the host is built again from the session as it stands, so + every redefinition accepted so far is in the new process from its first + instruction rather than delivered to it later. *) + let relaunch () = + Session.rehost session; + build_host (); + spawn () + in let t = { session; child = Some child; agent; dir; stdout = rd; + relaunch = Some relaunch; out = Buffer.create 4096; n = 0; gen = 0; owners = Hashtbl.create 32; host_ll; host_exe = exe; finished = false; agent_watch = None; park_noted = false; died = None; dropped = 0 } @@ -5326,9 +5561,12 @@ let two_process ?(debug = false) ?(x86 = true) ~file ~sock () = ((Unix.gettimeofday () -. t0) *. 1000.); Fun.protect ~finally:(fun () -> - (try Unix.kill child Sys.sigterm with Unix.Unix_error _ -> ()); + (match t.child with + | Some child -> + (try Unix.kill child Sys.sigterm with Unix.Unix_error _ -> ()) + | None -> ()); (try Unix.close ls with Unix.Unix_error _ -> ()); - (try Unix.close rd with Unix.Unix_error _ -> ()); + (try Unix.close t.stdout with Unix.Unix_error _ -> ()); (try Unix.unlink sock with Unix.Unix_error _ -> ())) (fun () -> accept_loop t ls); (* Here only when the loop returned: an exception out of it has already @@ -6171,7 +6409,7 @@ let merged_setup () = with Unix.Unix_error _ -> Sys.executable_name in let t = - { session; child = None; agent; dir; stdout = rd; + { session; child = None; agent; dir; stdout = rd; relaunch = None; out = Buffer.create 4096; n = 0; gen = 0; owners = Hashtbl.create 32; host_ll; host_exe = exe; finished = false; agent_watch = None; park_noted = false; died = None; dropped = 0 } @@ -6254,7 +6492,7 @@ let merged_serve () = (* The merged build is made here and then [exec]'d, so what an editor talks to is the program itself rather than something that launched it. The launcher does not survive: there is one process from the first reply onwards. *) -let start_merged ?(debug = false) ?(x86 = true) ~file ~sock () = +let start_merged ?(debug = false) ?(sanitize = false) ?(x86 = true) ~file ~sock () = let t0 = Unix.gettimeofday () in let dir = session_dir ~file ~sock in let given = file in @@ -6272,7 +6510,8 @@ let start_merged ?(debug = false) ?(x86 = true) ~file ~sock () = let host_ll = Filename.concat dir (if x86 then "host.s" else "host.ll") in ignore (merged_executable - ~opts:{ Build.default with Build.dev = true; Build.debug; Build.x86 } + ~opts:{ Build.default with Build.dev = true; Build.debug; + Build.sanitize; Build.x86 } ~csrcs ~lflags ~pnames:[] session.Session.host ~out:exe ~ll:host_ll); (* Read by the park, so the first one says the session is waiting rather @@ -6285,6 +6524,9 @@ let start_merged ?(debug = false) ?(x86 = true) ~file ~sock () = that the game thread's [getenv] cannot race the compiler thread's [putenv]: there is no ordering left to get wrong. *) Unix.putenv "FLAN_AGENT_SOCKET" agent; + (* This pid, because the exec below keeps it: the program is the owner + flan_agent.c's [daemon_socket] looks for. *) + Unix.putenv "FLAN_AGENT_OWNER" (string_of_int (Unix.getpid ())); Unix.putenv "FLAN_DEV_SOURCE" file; Unix.putenv "FLAN_DEV_SOCK" sock; Unix.putenv "FLAN_DEV_DIR" dir; @@ -6310,7 +6552,17 @@ let start_merged ?(debug = false) ?(x86 = true) ~file ~sock () = flan.cmxa beside the binary — and it is what every behaviour in this file was written against, so it stays until the transport it exists to drive is actually deleted. *) -let start ?(debug = false) ?(merged = true) ?(x86 = true) ~file ~sock () = +let start ?(debug = false) ?(sanitize = false) ?(merged = true) ?(x86 = true) + ~file ~sock () = + (* The sanitizers are LLVM passes, and the x86 backend's host is written + by hand with no pass run over it. The modules a session sends are not + instrumented on either backend; what is checked is the host and the + runtime, which is where a dev session's own bookkeeping lives. *) + if x86 && sanitize then + failwith + "flan dev --x86 --sanitize: the sanitizers instrument LLVM's output, and \ + the x86 backend writes its code by hand, so the program's own code \ + would not be checked. Drop --x86 to build this session with LLVM."; (* x86 unless told otherwise, and the default is here rather than only in [bin/main.ml] so that there is one answer to "what backend is a dev session". A library caller that starts a daemon starts the same daemon the @@ -6360,5 +6612,5 @@ let start ?(debug = false) ?(merged = true) ?(x86 = true) ~file ~sock () = [--x86 --debug] above is still refused, and for a reason that has nothing to do with this one. *) - if merged then start_merged ~debug ~x86 ~file ~sock () - else two_process ~debug ~x86 ~file ~sock () + if merged then start_merged ~debug ~sanitize ~x86 ~file ~sock () + else two_process ~debug ~sanitize ~x86 ~file ~sock () diff --git a/lib/emit.ml b/lib/emit.ml index edd3773a..01b82b72 100644 --- a/lib/emit.ml +++ b/lib/emit.ml @@ -370,7 +370,7 @@ let rec ll (t : Types.t) = integer spelling costs no casts and keeps the emitter honest about not knowing whether the bits are a pointer. *) | Types.Dyn -> "i64" - | Types.Var _ -> + | Types.Var _ | Types.Len _ | Types.LArray _ -> (* The checker rejects it by name — nothing reaches here. *) internal "no layout for %s" (Types.to_string t) @@ -539,6 +539,12 @@ type m = { [annot]. *) ann : bool; mutable nstr : int; + (* Set while an expression thunk's module is emitted: a string literal's + value is then a copy [flan_dev_literal] keeps for the life of the + process, so storing it anywhere leaves nothing pointing into the module, + and the literal is not counted in [nstr]. Without it every C-x C-e that + wrote a string or a keyword kept its mapping. *) + mutable pool : bool; (* The frame descriptors a dev build's shadow stack points at, counted apart from [nstr] deliberately. [nstr] is the test [redefinition] uses to decide whether an expression thunk's module may be unloaded — a string literal in @@ -641,7 +647,8 @@ let rec lay m (t : Types.t) : int * int = | Some u -> union_lay m u | None -> internal "no layout for struct %s" n) | Types.Dyn -> 8, 8 - | Types.Var _ -> internal "no layout for %s" (Types.to_string t) + | Types.Var _ | Types.Len _ | Types.LArray _ -> + internal "no layout for %s" (Types.to_string t) (* Size, alignment, and the offset of every member. *) and lay_fields m tys = @@ -1204,7 +1211,7 @@ let rec dty m d (t : Types.t) : int = reading: it prints, and the person reading it can hand it to the runtime's own printer. *) | Types.Dyn -> basic "dyn" 64 "DW_ATE_unsigned" - | Types.Var _ -> + | Types.Var _ | Types.Len _ | Types.LArray _ -> internal "no debug type for %s" (Types.to_string t) in Hashtbl.replace d.dtys key n; @@ -2591,6 +2598,16 @@ and value_at f (e : Tast.expr) : string = | Tast.Int (n, _) -> Int64.to_string n | Tast.Float (x, k) -> float_const k x | Tast.Bool b -> if b then "true" else "false" + | Tast.Str s when f.md.pool -> + (* See [pool]: the bytes are still this module's, but only the copy + leaves it, so they are [fi_bytes]' kind of constant and not + [string_bytes']. The copy carries the NUL. *) + let id, n = fi_bytes f.md s in + let p = fresh f in + ins f "%s = call ptr @flan_dev_literal(ptr %s, i64 %d)" p id n; + let v = fresh f in + ins f "%s = insertvalue %%slice { ptr poison, i64 %d }, ptr %s, 0" v n p; + v | Tast.Str s -> string_const f.md s | Tast.Unit | Tast.Zero _ | Tast.None_ -> "zeroinitializer" | Tast.Uninit _ -> "poison" @@ -3161,6 +3178,9 @@ and call_ptr ?at f ret callee args = code, Some ("ptr " ^ env) | _ -> c, None in + (match callee.Tast.ty, at with + | Types.CFn _, Some loc -> null_check f loc callee.Tast.ty code + | _ -> ()); let vs = map_lr (fun (a : Tast.expr) -> let v = value f a in Printf.sprintf "%s %s" (ll a.Tast.ty) v) args in Option.iter (mark_call f) at; @@ -3168,6 +3188,19 @@ and call_ptr ?at f ret callee args = if at <> None then clear_call f; r +(* A (CFn ...) may be a zeroed field, array element or global, and a zeroed + one is a null address. Tested before the arguments are evaluated, so a + call that is not going to be made runs none of them — the x86 backend + tests at the same point. [flan_null_call] signals [NullCall] and returns + only when something transferred, the shape of a bounds failure. *) +and null_check f loc ty code = + let ok = fresh f in + ins f "%s = icmp ne ptr %s, null" ok code; + signal_block f loc ~guard:(fun () -> guard f) ok (fun id n -> + let tys = fst (fi_bytes f.md (Types.to_string ty ^ "\000")) in + ins f "call void @flan_null_call(ptr %s, i64 %d, ptr %s, ptr %s)" + id n tys xfer_param) + (* The code address behind one of the three [fnref]s, which is the same string whether it is wanted as a bare [(Ptr ())] or as the first word of a function value. @@ -4909,10 +4942,14 @@ declare void @flan_arith_error(ptr, i64, i32, i64, i64, ptr) cold ; as C strings, then the cell and the channel. Signals StaleCall; returns when ; something answered. declare void @flan_stale_call(ptr, ptr, ptr, ptr, ptr) cold +; A call through a (CFn ...) holding null: the site, the value's type as a C +; string and the channel. Signals NullCall; returns when something answered. +declare void @flan_null_call(ptr, i64, ptr, ptr) cold declare ptr @flan_context_allocator() declare ptr @flan_context_use(ptr, i64) declare void @flan_context_value(ptr) declare void @flan_free_temp() +declare void @flan_slice_free(ptr, i64, i64, i64, ptr, ptr, i64) declare i8 @flan_i64_temp(i64, ptr) declare i8 @flan_f64_temp(double, ptr) declare void @flan_alloc_seal(ptr, ptr) @@ -4992,6 +5029,8 @@ declare void @flan_dev_watch_emit_i64(i64) declare void @flan_dev_watch_emit_u64(i64) declare void @flan_dev_watch_emit_f64(double) declare void @flan_dev_watch_end() +; An expression thunk's string literals, copied to storage the process keeps. +declare ptr @flan_dev_literal(ptr, i64) declare i64 @flan_dyn_need_i64(i64) declare double @flan_dyn_need_f64(i64) declare i32 @flan_dyn_need_bool(i64) @@ -5018,6 +5057,7 @@ declare void @flan_dyn_root_globals_end() declare void @flan_gc_init() declare void @flan_dev_reg_enable() declare void @flan_dev_reg_note_vec(ptr, i64, ptr, i64) +declare void @flan_dev_reg_note_slice(ptr, i64, ptr, i64) declare void @flan_dev_reg_note_map(ptr, i64, i64, ptr, i64) declare void @flan_dev_reg_note_res_acquire(i64, ptr, i64, ptr, i64) declare void @flan_dev_reg_note_res_release(i64, ptr, i64, ptr, i64) @@ -5309,7 +5349,7 @@ let new_module ~checks ~dev ~known ?(debug = false) ?(sanitize = false) globals = Hashtbl.create 16; externs = Hashtbl.create 32; checks; dev; gcfn = dev || makes_closures p; - known; nstr = 0; nfi = 0; sanitize; ann = annotate; + known; nstr = 0; pool = false; nfi = 0; sanitize; ann = annotate; descs = Hashtbl.create 8; dbg = (if debug then Some (new_dbg p) else None); fsigs = fsigs_of p; @@ -5752,6 +5792,43 @@ let program ?(checks = true) ?(dev = false) ?(debug = false) ?(pnames = []) String literals still have to come along: they are this module's own constants, and omitting them is an undefined [@.str.N] at link time. *) + +(* Whether an expression thunk makes a function value anywhere in its body or + in the clauses lifted out of it. Such a value's code address is in this + module — a lambda's body, or the thick wrapper a named function is handed + out through — and it may be stored anywhere, so the module must stay + mapped. Both backends ask this before marking a thunk's module + unloadable. *) +let thunk_makes_fn_values (p : Tast.program) name = + let mine = Hashtbl.create 8 in + Hashtbl.replace mine name (); + (* Lifted clauses nest: a lambda inside a lambda is lifted out of the + outer one's body, so the set grows until nothing new joins it. *) + let rec close () = + let grew = ref false in + List.iter + (fun (f : Tast.fn) -> + match f.Tast.fparent with + | Some q when Hashtbl.mem mine q && not (Hashtbl.mem mine f.Tast.name) -> + Hashtbl.replace mine f.Tast.name (); grew := true + | _ -> ()) + p.Tast.fns; + if !grew then close () + in + close (); + let found = ref false in + List.iter + (fun (f : Tast.fn) -> + if Hashtbl.mem mine f.Tast.name then + List.iter + (Tast.walk (fun (e : Tast.expr) -> + match e.Tast.e with + | Tast.FnAddr _ | Tast.Closure _ | Tast.Thicken _ -> found := true + | _ -> ())) + f.Tast.body) + p.Tast.fns; + !found + let redefinition ?(checks = true) ?(dev = false) ?(debug = false) ?(known = fun _ -> true) ?(retains = true) ?call ?(consts = []) ?(annotate = false) (p : Tast.program) ~fns @@ -5791,6 +5868,7 @@ let redefinition ?(checks = true) ?(dev = false) ?(debug = false) List.filter (fun (f : Tast.fn) -> f.Tast.fparent = None) p.Tast.fns in let m = new_module ~checks ~dev ~known ~debug ~annotate p in + m.pool <- call <> None && retains; (* A thunk the module runs itself is excluded from all of this: it is called directly by [flan_reload_call], so it needs no cell, must not be published into one, and must not take a registry slot — there are 4096 of those and @@ -5910,7 +5988,7 @@ let redefinition ?(checks = true) ?(dev = false) ?(debug = false) let t = fresh () in Buffer.add_string b (Printf.sprintf " %s = call ptr @flan_dev_cell(ptr %s)\n store ptr %s, ptr %s\n" - t (cstring m (Mangle.sym f.Tast.name)) t (cellptr f.Tast.name))) + t (fi_cstring m (Mangle.sym f.Tast.name)) t (cellptr f.Tast.name))) new_fns; List.iter (fun (g : Tast.global) -> @@ -5929,8 +6007,10 @@ let redefinition ?(checks = true) ?(dev = false) ?(debug = false) match initial_image p g with | None -> "null" | Some v -> - let init = Printf.sprintf "@\".init.%d\"" m.nstr in - m.nstr <- m.nstr + 1; + (* Copied by the runtime and not kept, so not counted in + [nstr]; a string inside it is, through [const]. *) + let init = Printf.sprintf "@\".init.%d\"" m.nfi in + m.nfi <- m.nfi + 1; Buffer.add_string m.strs (Printf.sprintf "%s = private constant %s %s\n" init (ll g.Tast.gty) (const m v)); @@ -5940,7 +6020,7 @@ let redefinition ?(checks = true) ?(dev = false) ?(debug = false) (Printf.sprintf " %s = call ptr @flan_dev_global(ptr %s, i64 ptrtoint (ptr getelementptr (%s, ptr null, i32 1) to i64), ptr %s)\n \ store ptr %s, ptr %s\n" - t (cstring m (Mangle.sym g.Tast.gname)) (ll g.Tast.gty) init t + t (fi_cstring m (Mangle.sym g.Tast.gname)) (ll g.Tast.gty) init t (globalptr g.Tast.gname))) new_globals; (* A constant whose value the checker never consumed is just bytes in the @@ -6009,10 +6089,12 @@ let redefinition ?(checks = true) ?(dev = false) ?(debug = false) expression may store one anywhere it likes — [(set msg "tuned")] on a string global leaves that global pointing into the mapping the agent is about to drop. The next thunk can be mapped at the same address, so - the result is silent garbage rather than a fault. A module with no - string constants has nothing in its image anyone could still be - pointing at; one with any keeps its mapping, which costs a page and is - the same bargain every redefinition already makes. *) + the result is silent garbage rather than a fault. So a thunk's + literal is a copy the process keeps (see [pool]) and is not counted; + what [nstr] still counts is a constant something may go on pointing + at, such as a condition's name, and a module with one keeps its + mapping. The registry names above are not counted: flan_dev.c copies + a name it keeps, and an initial image is copied on allocation. *) (* [retains = false] is a caller saying it knows where every literal in this module goes. The [m.nstr] test below is a conservative stand-in for that — an expression may store a string literal anywhere it likes, @@ -6022,7 +6104,8 @@ let redefinition ?(checks = true) ?(dev = false) ?(debug = false) into the result buffer, so nothing outside the module holds an address inside it once the call has returned. Without this, clicking through the frames of a break loop costs a permanent mapping per click. *) - if fns = [ fn ] && consts = [] && ((not retains) || m.nstr = 0) then + if fns = [ fn ] && consts = [] && ((not retains) || m.nstr = 0) + && not (thunk_makes_fn_values p fn) then Buffer.add_string m.out "\n@flan_reload_transient = global i8 1\n" | None -> () end; diff --git a/lib/indent_printer.ml b/lib/indent_printer.ml index eb3bfd38..3b7b2512 100644 --- a/lib/indent_printer.ml +++ b/lib/indent_printer.ml @@ -200,13 +200,17 @@ and inline_text ?(lvl = 0) (f : Form.t) = 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 + | Form.List [ { v = Form.Sym "update"; _ }; t; { v = Form.Sym (("+" | "-" | "*" | "/") as op); _ }; w ] + when not (R.simple_place t) -> + at 9 t ^ " " ^ op ^ "= " ^ at (max lvl 1) w | _ -> 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 -> + | Form.List [ { v = Form.Sym (("+" | "-" | "*" | "/") as op); _ }; a; w ] + when same a t && R.simple_place t -> tt ^ " " ^ op ^ "= " ^ at (max lvl 1) w | _ -> tt ^ " = " ^ at (max lvl 1) v @@ -325,7 +329,7 @@ let body_split (h : Form.t) args = let sugar_heads = [ "let"; "set"; "if"; "when"; "cond"; "while"; "until"; "dotimes"; "match"; "handler-case"; "handler-bind"; "restart-case"; "return"; "defer"; "do"; - "quasiquote" ] + "quasiquote"; "update" ] let rec block n (fs : Form.t list) : string list = let rec go = function @@ -441,6 +445,9 @@ and sugar n ~last (f : Form.t) : string list option = (match pairs bs with | None | Some [] -> None | Some prs -> Some (let_lines n ~last prs body)) + | Form.List [ { v = Form.Sym "update"; _ }; t; { v = Form.Sym ("+" | "-" | "*" | "/"); _ }; _ ] + when not (R.simple_place t) -> + Some [ i ^ guard (inline_text f) ] | 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 ] diff --git a/lib/indent_reader.ml b/lib/indent_reader.ml index 436bba59..2f8ad73f 100644 --- a/lib/indent_reader.ml +++ b/lib/indent_reader.ml @@ -64,6 +64,35 @@ let is_op_word s = is_binop s || s = "not" || s = "=" let assign_ops = [ ("+=", "+"); ("-=", "-"); ("*=", "*"); ("/=", "/") ] +(* A place whose parts are all names and literals reads the same however + often it is evaluated, so [x += v] over one is [(set x (+ x v))], the form + the Lisp side writes. Any other place — an index that is a call — reads + [(update p + v)], which evaluates each part of the place once. The printer + asks the same question, so the round trip is exact either way. *) +let rec simple_place (f : Form.t) = + let atom (x : Form.t) = + match x.v with + | Form.Sym _ | Form.Int _ | Form.Kw _ | Form.Byte _ -> true + | _ -> false + in + match f.v with + | Form.Sym _ -> true + | Form.List [ { v = Form.Sym h; _ }; t ] + when (String.length h > 1 && h.[0] = '.') || h = "deref" -> + simple_place t + | Form.List ({ v = Form.Sym "at"; _ } :: t :: (_ :: _ as idx)) -> + simple_place t && List.for_all atom idx + | _ -> false + +let compound (at : Loc.t) op (e : Form.t) (v : Form.t) span = + if simple_place e then + Form.List + [ Form.make (Form.Sym "set") at; e; + Form.make (Form.List [ Form.make (Form.Sym op) at; e; v ]) span ] + else + Form.List + [ Form.make (Form.Sym "update") at; e; Form.make (Form.Sym op) at; v ] + (* 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 = @@ -724,11 +753,7 @@ and inline_stmt p : Form.t = | 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) ]) + mk p t.loc (compound 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 @@ -1125,10 +1150,7 @@ and expr_stmt (s : st) : Form.t = 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) ]) + mk p t0.loc (compound eq.loc o e v (span p e.loc)) | COLON -> let before = (last p).tok in let c = advance p in diff --git a/lib/js.ml b/lib/js.ml index 74f86563..a8f01620 100644 --- a/lib/js.ml +++ b/lib/js.ml @@ -249,6 +249,8 @@ let rec refuse_ty loc (t : Types.t) = host's own, and that work has not been done" | Types.Var n -> at loc "a type variable (%s) reached the backend, which cannot happen" n + | Types.Len _ | Types.LArray _ -> + at loc "a length variable reached the backend, which cannot happen" (* Aggregates in the sense that matters here: the types whose assignment copies in Flan and would alias in JS. A slice is deliberately not one — diff --git a/lib/load.ml b/lib/load.ml index 70bb75cb..9b5688b5 100644 --- a/lib/load.ml +++ b/lib/load.ml @@ -213,8 +213,11 @@ let rec rename_texpr owned alias (t : Ast.texpr) : Ast.texpr = Ast.Tarray (rename_len owned alias l, rename_texpr owned alias e) | Ast.Tmap (k, v) -> Ast.Tmap (rename_texpr owned alias k, rename_texpr owned alias v) + (* The head too, when it is a generic struct the package declares. *) | Ast.Tapp (n, args) -> + let n = if List.mem n owned then qualify alias n else n in Ast.Tapp (n, List.map (rename_texpr owned alias) args) + | Ast.Tlen _ as k -> k | Ast.Tfn (env, ps, r) -> Ast.Tfn (env, List.map (rename_texpr owned alias) ps, rename_texpr owned alias r) @@ -800,8 +803,11 @@ let rec texpr_uses acc (t : Ast.texpr) = (match l with Ast.Lname n -> acc := (n, t.Ast.tloc) :: !acc | Ast.Lint _ -> ()); texpr_uses acc e | Ast.Tmap (k, v) -> texpr_uses acc k; texpr_uses acc v - | Ast.Tapp (_, args) -> List.iter (texpr_uses acc) args + | Ast.Tapp (n, args) -> + acc := (n, t.Ast.tloc) :: !acc; + List.iter (texpr_uses acc) args | Ast.Tfn (_, ps, r) -> List.iter (texpr_uses acc) ps; texpr_uses acc r + | Ast.Tlen _ -> () let rec expr_uses acc (e : Ast.expr) = let go = expr_uses acc in @@ -1618,6 +1624,7 @@ let program ?(parse = Parse.program) ~file (forms : Form.t list) : t = in let decls = Parse.with_imported ~decls:(imported.decls @ !Parse.imported_decls) + ~fns:!Parse.shadowing_fns (macro_union imported.macros !Parse.imported_macros) (fun () -> parse forms) in diff --git a/lib/loc.ml b/lib/loc.ml index 9cfb41e4..c72cf840 100644 --- a/lib/loc.ml +++ b/lib/loc.ml @@ -205,6 +205,7 @@ let caught s f = match f () with | x -> Some x | exception Error d -> s.found <- d :: s.found; None + | exception Errors ds -> s.found <- List.rev_append ds s.found; None (** Raise everything found, in the order it was found, or return if the pass was clean. *) diff --git a/lib/macro.ml b/lib/macro.ml index ae2577e7..1e570d0f 100644 --- a/lib/macro.ml +++ b/lib/macro.ml @@ -585,10 +585,39 @@ let with_module (l : loaded) (f : unit -> 'a) : 'a = left in them, so a second pass only reaches the calls to the new names. A macro that defines a macro whose expansion defines another costs one pass per level, and the fuel is the same bound [settle] uses. *) +(* The names these forms define as functions. A program's [defn] shadows a + macro of the same name — the prelude's [clamp] or [update], or an + imported one — as it shadows a prelude function: every call in the file + reaches the definition, and [Check.shadow_prelude] says so. So such a + name is not expanded here. A [defmacro] is a [defn] too once parsed, but + not yet: [macro_name] is what finds those, and they are left alone. *) +let defined_fns (forms : Form.t list) = + List.filter_map + (fun (f : Form.t) -> + match f.Form.v with + | Form.List ({ Form.v = Form.Sym ("defn" | "defn-"); _ } + :: { Form.v = Form.Sym n; _ } :: _) -> Some n + | _ -> None) + forms + let rec program_n left (forms : Form.t list) : Form.t list = match loaded_for forms with | None -> forms | Some l -> + (* Never the prelude's own forms: they are parsed inside a session's + evaluation too, and their calls are to their own macros. *) + let prelude = + match forms with + | f :: _ -> String.equal f.Form.loc.Loc.file Prelude.file + | [] -> false + in + let shadowed = + if prelude then [] else defined_fns forms @ !Parse.shadowing_fns + in + let l = + if shadowed = [] then l + else { l with fns = List.filter (fun (n, _) -> not (List.mem n shadowed)) l.fns } + in let before = macros_in forms in let out = with_module l (fun () -> List.map (expand_form l) forms) in let fresh = List.filter (fun n -> not (List.mem n before)) (macros_in out) in diff --git a/lib/parse.ml b/lib/parse.ml index e5190994..a9aa6e0c 100644 --- a/lib/parse.ml +++ b/lib/parse.ml @@ -30,6 +30,32 @@ let no_sigil (f : Form.t) = let dname (f : Form.t) = no_sigil f; sym f +(* A global's name. One spelled like a built-in type would stand where the + type is written — [(vec-new u8)] — and change what that means, in the + program and in the prelude alike, so it is refused where it is declared. *) +let gname (f : Form.t) = + (match f.v with + | Sym s when List.mem s Types.primitive_names -> + Loc.failk "parse/global-named-type" f.loc + "%s is a type, so it cannot also name a global — (vec-new %s) would \ + not know which was meant. Name it %s-value, or any name that is not \ + a type" + s s s + | _ -> ()); + dname f + +(* A type's name. A built-in type's is taken: a second [u8] would stand for + one or the other wherever a type is written, the prelude's included. *) +let tname (f : Form.t) = + (match f.v with + | Sym s when List.mem s Types.primitive_names -> + Loc.failk "parse/type-named-builtin" f.loc + "%s is a built-in type, so it cannot be declared again. Give the new \ + type a name of its own" + s + | _ -> ()); + dname f + (* Names for the temporaries this file mints — the value is bound once and everything that needs it reads *that*, so a destructuring pattern over a call calls it once and a short-circuit operand is evaluated once. [~] is a @@ -73,6 +99,16 @@ let no_pattern (f : Form.t) = (* ── Type expressions ──────────────────────────────────────────────── *) +(* A type constructor's spelling: its last segment starts with a capital. *) +let capitalised_name name = + let base = + match String.rindex_opt name '/' with + | Some i -> String.sub name (i + 1) (String.length name - i - 1) + | None -> name + in + base <> "" && Char.uppercase_ascii base.[0] = base.[0] + && Char.lowercase_ascii base.[0] <> base.[0] + let rec texpr (f : Form.t) : Ast.texpr = let mk t = { Ast.t; tloc = f.loc } in match f.v with @@ -135,8 +171,44 @@ let rec texpr (f : Form.t) : Ast.texpr = | [ { v = Vec params; _ }; ret ] -> mk (Ast.Tfn (env, List.map texpr params, texpr ret)) | _ -> fail f "a function type is (%s [T ...] R)" which) - | List ({ v = Sym name; _ } :: args) when args <> [] -> - mk (Ast.Tapp (name, List.map texpr args)) + | List ({ v = Sym name; _ } :: args) + when args <> [] || capitalised_name name -> + (* An integer argument is a generic struct's length, and a type + constructor is capitalised. A lowercase head is a body form in the + return slot — (+ x 1) — and its integer is the type parser's reason to + give up, which is the refusal that slot is built on. *) + let capitalised = capitalised_name name in + (* Integer arithmetic over literals is a length too — [(Small (+ 4 4) + i32)] — folded here, since nothing later reads it as a value. *) + let rec fold (a : Form.t) = + match a.v with + | Int n -> Some n + | List ({ v = Sym (("+" | "-" | "*") as op); _ } :: (_ :: _ as xs)) -> + let vs = List.map fold xs in + if List.for_all Option.is_some vs then + let vs = List.map Option.get vs in + match op, vs with + | "-", [ x ] -> Some (Int64.neg x) + | "+", v :: rest -> Some (List.fold_left Int64.add v rest) + | "-", v :: rest -> Some (List.fold_left Int64.sub v rest) + | "*", v :: rest -> Some (List.fold_left Int64.mul v rest) + | _ -> None + else None + | _ -> None + in + let arg (a : Form.t) = + match a.v, fold a with + | _, Some n when capitalised -> { Ast.t = Ast.Tlen n; tloc = a.loc } + | List _, None when capitalised -> + (try texpr a with + | Loc.Error _ -> + fail a + "%s is not a type or a length. An argument here is a type, or a \ + length: an integer, a constant's name or a length variable" + (Form.to_string a)) + | _ -> texpr a + in + mk (Ast.Tapp (name, List.map arg args)) | _ -> fail f "expected a type, found %s" (Form.to_string f) and len (f : Form.t) : Ast.len = @@ -449,6 +521,14 @@ and form f mk (head : Form.t) (args : Form.t list) : Ast.expr = | [ target; value ] -> mk (Ast.Set (place target, expr value)) | _ -> fail f "set is (set place value)") + (* What [update], [++] and [--] expand into: (update~ PLACE g NEW), where + NEW is written over the name [g]. The name has a [~] in it so no program + can write it; only a prelude macro builds one. See [modify]. *) + | Sym "update~" -> + (match args with + | [ target; { v = Sym g; _ }; value ] -> modify f target g value + | _ -> fail f "internal: update~ is (update~ place name value) — a compiler bug") + (* ── (vec-new [u8]) and (map-new string [u8]) ─────────────────────── The type positions of these two take a type expression. Whether this call is the builtin at all is the checker's to know — a program may define its @@ -1174,17 +1254,10 @@ and cond f (args : Form.t list) : Ast.expr = [f.loc] would blame the enclosing (and ...) for whichever operand is actually wrong. - What answering the operand costs, for both forms alike: the two arms are - now both real values, so mixing a dyn operand with a typed bool one makes - check_if unify them, and the then arm decides. A non-bool dyn value on - the losing side then meets the strict bool boundary at run time — - (or false (box "s")) and (and (box nil) some-bool) both trap, verified on - this tree. Each form used to be safe in exactly one of those directions, - because the sentinel it answered was a bool literal that boxed to fit - whatever the real branch was; neither is now, and they are at least - symmetric about it. Making bool and dyn arms join as dyn is a check_if - question, noted in TODO.org, "A bool arm and a dyn arm joining as dyn", - and not decided here. + The two arms are both real values, so mixing a dyn operand with a typed + bool one makes check_if unify them: a bool arm and a dyn arm meet at dyn + with the bool boxed, whichever side each is on, so (or false (box "s")) + answers "s" and (and (box nil) some-bool) answers nil. One known wart, measured rather than guessed, and left alone deliberately. In a want-free position — [(println (and true true (vec-new i32)))] — the @@ -1252,6 +1325,65 @@ and place (f : Form.t) : Ast.place = (deref p), or a class slot (get inst :slot)" (Form.to_string f) +(* A read-modify-write of a place, with every subexpression of the place + evaluated once — C's rule for compound assignment. (update (at grid (next) + c) inc) calls [next] once, and the read and the write land on the same + element. + + Each index, key and pointer is bound to a temp first, outermost and + leftmost first. The container a field or an index is taken from is not: it + has to stay a path to the storage, since a temp would be a copy of a struct + or an array and the write would land in the copy. Only a path made of + names, fields, indexes and derefs stays one; anything else in container + position — a call answering a Vec, say — is a value, and is bound like an + index. Then [g] is bound to the place's current value, and [value], written + over [g], is stored back through the same path. *) +and modify f target g value : Ast.expr = + let mk e = { Ast.e; loc = f.loc } in + let binds = ref [] in + let temp (e : Ast.expr) = + match e.Ast.e with + | Ast.Int _ | Ast.UInt _ | Ast.Float _ | Ast.Byte _ | Ast.Str _ | Ast.Kw _ -> e + | _ -> + let t = fresh_temp "place" in + binds := { Ast.bname = t; bty = None; bval = e; bloc = e.Ast.loc } :: !binds; + { e with Ast.e = Ast.Var t } + in + let rec path (e : Ast.expr) = + match e.Ast.e with + | Ast.Var _ -> e + | Ast.Field (t, n) -> { e with Ast.e = Ast.Field (path t, n) } + | Ast.Call (({ Ast.e = Ast.Var "at"; _ } as h), t :: idx) when idx <> [] -> + let t = path t in + { e with Ast.e = Ast.Call (h, t :: List.map temp idx) } + | Ast.Call (({ Ast.e = Ast.Var "deref"; _ } as h), [ p ]) -> + { e with Ast.e = Ast.Call (h, [ temp p ]) } + | _ -> temp e + in + let p = + match place target with + | Ast.Pvar _ as p -> p + | Ast.Pfield (t, n) -> Ast.Pfield (path t, n) + | Ast.Pindex (t, idx) -> + let t = path t in + Ast.Pindex (t, List.map temp idx) + | Ast.Pderef p -> Ast.Pderef (temp p) + | Ast.Pslot (t, k) -> + let t = temp t in + Ast.Pslot (t, temp k) + in + let at e = { Ast.e; loc = target.loc } in + let read = + match p with + | Ast.Pvar n -> at (Ast.Var n) + | Ast.Pfield (t, n) -> at (Ast.Field (t, n)) + | Ast.Pindex (t, idx) -> at (Ast.Call (at (Ast.Var "at"), t :: idx)) + | Ast.Pderef p -> at (Ast.Call (at (Ast.Var "deref"), [ p ])) + | Ast.Pslot (t, k) -> at (Ast.Call (at (Ast.Var "get"), [ t; k ])) + in + let old = { Ast.bname = g; bty = None; bval = read; bloc = target.loc } in + mk (Ast.Let (List.rev (old :: !binds), [ mk (Ast.Set (p, expr value)) ])) + and arms f (items : Form.t list) : Ast.arm list = let rec go = function | [] -> [] @@ -1343,7 +1475,13 @@ let rec decl (f : Form.t) : Ast.decl = | List ({ v = Sym "defalias"; _ } :: args) -> (match args with - | [ n; t ] -> mk (Ast.Defalias (dname n, texpr t)) + (* int and float restate a builtin alias, which the checker takes up; + any other built-in type's name is refused as tname refuses it. *) + | [ n; t ] -> + let name = + match n.v with Sym ("int" | "float") -> dname n | _ -> tname n + in + mk (Ast.Defalias (name, texpr t)) | _ -> fail f "defalias is (defalias Name Type)") (* A parent comes before the fields, where Common Lisp's define-condition @@ -1353,16 +1491,16 @@ let rec decl (f : Form.t) : Ast.decl = | List ({ v = Sym "defstruct"; _ } :: args) -> (match args with | [ n; { v = Vec fs; _ } ] -> - mk (Ast.Defstruct (dname n, fields f fs, None)) + mk (Ast.Defstruct (tname n, fields f fs, None)) | [ n; { v = Kw "parent"; _ }; p; { v = Vec fs; _ } ] when fs <> [] -> - mk (Ast.Defstruct (dname n, fields f fs, Some (texpr p))) + mk (Ast.Defstruct (tname n, fields f fs, Some (texpr p))) (* An empty field vector is the same category as none. *) | [ n; { v = Kw "parent"; _ }; p ] | [ n; { v = Kw "parent"; _ }; p; { v = Vec []; _ } ] -> let str name = { Ast.fname = name; fty = { Ast.t = Ast.Tname "string"; tloc = f.loc }; floc = f.loc } in - mk (Ast.Defstruct (dname n, [ str "name"; str "message" ], Some (texpr p))) + mk (Ast.Defstruct (tname n, [ str "name"; str "message" ], Some (texpr p))) | _ -> fail f "defstruct is (defstruct Name [field Type ...]), or with a parent \ @@ -1370,7 +1508,7 @@ let rec decl (f : Form.t) : Ast.decl = | List ({ v = Sym "defdata"; _ } :: args) -> (match args with - | [ n; { v = Vec vs; _ } ] -> mk (Ast.Defdata (dname n, List.map variant vs)) + | [ n; { v = Vec vs; _ } ] -> mk (Ast.Defdata (tname n, List.map variant vs)) | _ -> fail f "defdata is (defdata Name [(Case [field Type ...]) ...])") (* C's union: one storage, as many ways of reading it as there are members. @@ -1413,7 +1551,7 @@ let rec decl (f : Form.t) : Ast.decl = [member Type ...]). This reads as a tagged sum — write \ (defdata Name [(Case [field Type ...]) ...])") ms; - mk (Ast.Defunion (dname n, fields f ms)) + mk (Ast.Defunion (tname n, fields f ms)) | _ -> fail f "defunion is (defunion Name [member Type ...])") (* The slot after the parameters is unconditionally the return type. It used @@ -1538,7 +1676,7 @@ let rec decl (f : Form.t) : Ast.decl = List.iter (fun (s : Form.t) -> match s.v with Sym _ -> no_sigil s | _ -> ()) slots; - mk (Ast.Defclass (dname n, pitems slots)) + mk (Ast.Defclass (tname n, pitems slots)) | _ -> fail f "defclass is (defclass Name [slot Type ...])") | List ({ v = Sym ("defgeneric" | "defmulti" as which); _ } :: args) -> @@ -1631,7 +1769,7 @@ let rec decl (f : Form.t) : Ast.decl = | List ({ v = Sym "defenum"; _ } :: args) -> (match args with | [ n; { v = Form.Vec ms; _ } ] -> - let ename = dname n in + let ename = tname n in (* An enum member is an [i32] at run time. [Shim] lowers the type to int32_t for C's benefit and [Check] builds every member as a [Tast.Int (v, I32)] -- but the reader hands this pass an [int64], so @@ -1781,11 +1919,11 @@ let rec decl (f : Form.t) : Ast.decl = (match args with | [ n; t ] -> let ty, init = defvar3 t in - mk (Ast.Defvar (dname n, Some ty, init, kind)) + mk (Ast.Defvar (gname n, Some ty, init, kind)) | [ n; t; { v = Sym "uninit"; _ } ] -> - mk (Ast.Defvar (dname n, Some (texpr t), Ast.Uninit, kind)) + mk (Ast.Defvar (gname n, Some (texpr t), Ast.Uninit, kind)) | [ n; t; v ] -> - mk (Ast.Defvar (dname n, Some (texpr t), Ast.Init (expr v), kind)) + mk (Ast.Defvar (gname n, Some (texpr t), Ast.Init (expr v), kind)) | _ -> fail f "%s is (%s name Type value?) or (%s name value) — a third element \ @@ -1824,8 +1962,8 @@ let rec decl (f : Form.t) : Ast.decl = | List ({ v = Sym "defconst"; _ } :: args) -> (match args with - | [ n; v ] -> mk (Ast.Defconst (dname n, None, expr v)) - | [ n; t; v ] -> mk (Ast.Defconst (dname n, Some (texpr t), expr v)) + | [ n; v ] -> mk (Ast.Defconst (gname n, None, expr v)) + | [ n; t; v ] -> mk (Ast.Defconst (gname n, Some (texpr t), expr v)) | _ -> fail f "defconst is (defconst name Type? value)") (* A macro is an ordinary function, and this is where it becomes one: @@ -2002,15 +2140,25 @@ let expansion_macros : Form.t list ref = ref [] written twice, in the file where the two copies could disagree silently. *) let imported_decls : Ast.decl list ref = ref [] -let with_imported ?(decls = []) (ms : Form.t list) (f : unit -> 'a) : 'a = +(* Functions a session already holds, by name. A program's [defn] shadows a + macro of its name, and a session's form is expanded alone, long after the + [defn] that shadows — so the session says which names those are, as it + says which macros it has. *) +let shadowing_fns : string list ref = ref [] + +let with_imported ?(decls = []) ?(fns = []) (ms : Form.t list) + (f : unit -> 'a) : 'a = let saved = !imported_macros in let saved_decls = !imported_decls in + let saved_fns = !shadowing_fns in imported_macros := ms; imported_decls := decls; + shadowing_fns := fns; Fun.protect ~finally:(fun () -> imported_macros := saved; - imported_decls := saved_decls) + imported_decls := saved_decls; + shadowing_fns := saved_fns) f (* Two entry points and not one function with a flag, and the reason is the diff --git a/lib/prelude.ml b/lib/prelude.ml index 92110375..5cc0ea01 100644 --- a/lib/prelude.ml +++ b/lib/prelude.ml @@ -197,6 +197,17 @@ let source = {flan| ;; nothing a handler supplies makes the old arguments fit the new body. (defstruct StaleCall :parent Error [callee string compiled string current string]) +;; A call through a (CFn ...) that holds no function. A CFn may be a struct +;; field, a fixed array's element or a global, and each of those starts out +;; zeroed, which for a function value is no address at all. Every call +;; through one tests first and signals this instead of jumping to nothing. +;; `type` is the value's type as written, "(CFn [i32] i32)". +;; +;; Signalled from the runtime — flan_null_call in runtime/flan_rt.c — so +;; **this field is a C struct that has to agree with this one**. No restart is +;; established at the call, BoundsError's decision for BoundsError's reason. +(defstruct NullCall :parent Error [type string]) + ;; What a generic function signals when no method answers. `generic` is the ;; name written at the defgeneric or defmulti, and `value` is what the ;; dispatch actually produced -- the class of the first argument for a @@ -240,6 +251,18 @@ let source = {flan| (defn pause [] () (restart-case (error (Pause {})) (continue [] (do)))) +;; The stepper's stop, which C-c C-s puts before each form of a defn's body +;; (Ast.instrument_step). It is (pause) with an answer: next goes on stepping +;; and continue runs the rest of the call, and the instrumented body keeps +;; that answer in a local of its own. Like Pause it is not under Error. +;; Named so a program's own step or Step is not what the instrumented body +;; calls. +(defstruct StepPoint []) + +(defn step-point [] bool + (restart-case (error (StepPoint {})) + (next [] :report "stop at the next form" true) + (continue [] :report "run the rest of this call" false))) ;; A seeded PRNG in Flan rather than libc's, because a grid hash is only a ;; regression test if the sequence is byte-identical on native and wasm32 @@ -2287,16 +2310,12 @@ let source = {flan| ;; because a macro does not have a type at all; the expansion is checked at the ;; call site as if it had been written there. ;; -;; **++ and -- read the place twice, and that is an accepted cost.** The -;; expansion is (set PLACE (+ PLACE 1)), so PLACE is evaluated once to read -;; and once to write. For a variable, a field or a deref that is free and -;; means nothing. For (at arr (next-index)) — an index with a side effect — -;; it means next-index runs twice and the read and the write land on different -;; elements. That is not a bug to be fixed here: macros are non-hygienic by -;; decision (plan.org, open decision 2), a macro cannot bind a temporary for -;; the *place* without a reference type it does not have, and -;; rl/with-drawing and rl/with-mode-2d already take the same trade on their -;; arguments. Write the index out first if it does anything. +;; **++ and -- evaluate the place once.** Each index, key and pointer in the +;; place is bound to a temp before the read, so (++ (at arr (next-index))) +;; calls next-index once and reads and writes the same element — C's rule for +;; compound assignment. They are update with + and -, spelled as the form +;; update~ that update itself expands into (a prelude macro may not call a +;; macro); lib/parse.ml's [modify] is where the place is taken apart. (defmacro inc [& args] (if (!= (length args) 1) `(inc-takes-one-number) @@ -2310,12 +2329,31 @@ let source = {flan| (defmacro ++ [& args] (if (!= (length args) 1) `(++-takes-one-place) - `(set ~(at args 0) (+ ~(at args 0) 1)))) + (let [g (gensym)] + `(~(Form.Sym {.s "update~"}) ~(at args 0) ~g (+ ~g 1))))) (defmacro -- [& args] (if (!= (length args) 1) `(---takes-one-place) - `(set ~(at args 0) (- ~(at args 0) 1)))) + (let [g (gensym)] + `(~(Form.Sym {.s "update~"}) ~(at args 0) ~g (- ~g 1))))) + +;; ── update: change a place by applying a function to it ──────────────── +;; +;; (update (.velocity g) inc) +;; (update (at grid r c) + 10) +;; +;; (update place f args ...) stores (f old args ...) back into the place, where +;; old is what the place held. f is written as the head of a call, so it may be +;; a function, an operator or a macro such as inc. Every place set takes is a +;; place here too — a name, a field, an element, a deref, a class slot — and +;; the place is evaluated once, as ++ says above. It answers what set answers. +(defmacro update [& args] + (if (< (length args) 2) + `(update-takes-a-place-and-a-function) + (let [g (gensym)] + `(~(Form.Sym {.s "update~"}) ~(at args 0) ~g + (~(at args 1) ~g ~@(form-rest args 2)))))) ;; ── into: a fused transformation, and not a transducer ──────────────── ;; @@ -2388,6 +2426,15 @@ let source = {flan| (form-sym? head "filter") (recur (- k 1) `(when (~f ~x) ~body)) :else `(into-transform-is-map-or-filter ~t)))))))) +;; Whether any transform in the chain is a (map f). +(defn into-maps? [ts [Form]] bool + (loop [k 0] + (cond + (= k (length ts)) false + (let [items (form-items (at ts k))] + (and (> (length items) 0) (form-sym? (at items 0) "map"))) true + :else (recur (+ k 1))))) + ;; The items of a list form, and the empty slice for anything else — a ;; non-list transform falls into the arity complaint above rather than needing ;; a case of its own. @@ -2440,10 +2487,19 @@ let source = {flan| named? (form-is-sym? from) src (if named? from (gensym)) bind (if named? (form-nil) (form-pair src from)) + ;; With no (map f) in the chain every element pushed is a source + ;; element as it stands, which copies only its header: the checker + ;; refuses that for an element that owns storage. The destination and + ;; the transforms ride along unevaluated, to be written back in the fix. + shares (if (into-maps? (form-rest args 2)) + (form-nil) + (form-cons `(into-copies-elements ~src ~(at args 1) ~@(form-rest args 2)) + (form-nil))) dst (gensym) x (gensym) i (gensym)] `(let [~dst ~(at args 1) ~@bind] + ~@shares (dotimes [~i (length ~src)] (let [~x (at ~src ~i)] ~(into-wrap (form-rest args 2) dst x))) diff --git a/lib/program.ml b/lib/program.ml index 45091410..e7177ae2 100644 --- a/lib/program.ml +++ b/lib/program.ml @@ -98,6 +98,5 @@ let rerun ?(stopped = false) () = its window, or let it finish, and ask again" | _ -> Error - "this session's program is a process of its own, so there is no parked \ - thread here to send round again; it is the merged build that can re-run \ - a program, not --two-process" + "this process has no program thread of its own, so there is nothing \ + here to run again" diff --git a/lib/render.ml b/lib/render.ml index c5cf9f6d..5cf3f33f 100644 --- a/lib/render.ml +++ b/lib/render.ml @@ -103,6 +103,12 @@ let print_refusal _loc t = Printf.sprintf "no printer for %s — print the values you want out of it" (Types.to_string t) +(* The head a struct value prints under: its name, or for a generic struct's + copy the template and its arguments, [Pair i32], so the value reads + [(Pair i32 {.a 1 .b 2})] the way its type is written. Every renderer of a + struct value goes through this, so they all print the same text. *) +let head n = Types.struct_head n + let rec render ?(refuse = print_refusal) c depth (e : Tast.expr) : Tast.expr list = let render c depth e = render ~refuse c depth e in let loc = e.Tast.loc in @@ -333,7 +339,7 @@ let rec render ?(refuse = print_refusal) c depth (e : Tast.expr) : Tast.expr lis @ render c (depth + 1) v) shown) in - [ do_ ((lit ("(" ^ n ^ " {") :: parts) + [ do_ ((lit ("(" ^ head n ^ " {") :: parts) @ (if List.length fields > max_span then [ lit " ..." ] else []) @ [ lit "})" ]) ]) (* A fixed array's length is in its type, so it unrolls — capped, because diff --git a/lib/session.ml b/lib/session.ml index d79508bc..3a1e371e 100644 --- a/lib/session.ml +++ b/lib/session.ml @@ -65,7 +65,7 @@ type t = { mutable decls : Ast.decl list; (* post-Load: flat, one namespace *) mutable program : Tast.program; (* the last thing that checked *) mutable env : Check.env; (* the same, as the checker sees it *) - host : Tast.program; (* what the process was built from *) + mutable host : Tast.program; (* what the process was built from *) pkgs : Load.pkg list; (* alias, directory, names owned *) (* Every [defmacro] this session can expand a call to: the imports', under their aliases, and the buffer's own, under the names the buffer writes. @@ -597,7 +597,7 @@ let compatible ~loc (old_ : Tast.program) (new_ : Tast.program) = if not same then fail loc "%s changes layout. Restart to change it." - s.Tast.sname + (Types.to_string (Types.Named s.Tast.sname)) | None -> ()) new_.Tast.structs @@ -782,19 +782,49 @@ let restore t h = newest one and no older activation is left running. *) let rerun t = t.live <- SM.empty +(* The process is about to be built again from what the session holds now + (a --two-process re-run), so that becomes what it was built from. Checked + whole rather than taken from [program], which can hold a caller's old body + beside a callee whose signature changed (see [eval]); a fresh build of that + pair would be wrong, so it raises the checker's error instead. *) +let rehost t = + let p, env = + let was = !Check.print_warnings in + Check.print_warnings := false; + Fun.protect ~finally:(fun () -> Check.print_warnings := was) + (fun () -> Check.program_with_env t.decls) + in + t.program <- p; + t.env <- env; + t.host <- p; + t.built <- record_built env p p.Tast.fns SM.empty; + t.live <- SM.empty + +(* The session's own functions whose names a macro also has — see + [Parse.shadowing_fns]. A [defmacro] is a [defn] once parsed, so the + session's macros are taken back out. *) +let shadowing_fns t origin = + let macros = List.filter_map Macro.macro_name (macros_for t origin) in + List.filter_map + (fun (d : Ast.decl) -> + match d.Ast.d with + | Ast.Defn fn when not (List.mem fn.Ast.name macros) -> Some fn.Ast.name + | _ -> None) + t.decls + (* [forms], when given, are [src] already read — [pruned] runs this over a file a form fewer each round and has no text for the subset. [base] is the file an [(import ...)] in them is resolved against, the session's own when absent: a file loaded from another directory names its packages from there. *) -let eval ?(origin = "") ?base ?forms ?pause ?(running = true) t src : change = +let eval ?(origin = "") ?base ?forms ?pause ?(step = false) ?(running = true) t src : change = let forms = 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. *) Loc.remember ~file:origin src; - Parse.with_imported ~decls:(package_decls t) (macros_for t origin) @@ fun () -> + Parse.with_imported ~decls:(package_decls t) ~fns:(shadowing_fns t origin) (macros_for t origin) @@ fun () -> (* Through [Load] like any other source, so an evaluated (import ...) means what it means in a file. Its expansion is what gets spliced, which is also why the accumulated list is the post-Load one: re-evaluating a file that @@ -877,6 +907,15 @@ let eval ?(origin = "") ?base ?forms ?pause ?(running = true) t src : chan fail loc "nothing to pause at line %d, column %d of the form sent" line col) in + (* [step]: every defn sent stops before each form of its body — see + [Ast.instrument_step]. After [qualify_decl] for the reason [pause] is. *) + let incoming = + if not step then incoming + else + match Ast.instrument_step incoming with + | Some ds -> ds + | None -> fail loc "there is no defn in the form sent to step through" + in (* A method declares a name of its own — that is what makes evaluating one twice a replacement and evaluating a new one an append, through the same kept/added logic every other declaration goes through. But no function is @@ -968,8 +1007,13 @@ let eval ?(origin = "") ?base ?forms ?pause ?(running = true) t src : chan && List.exists stale_site b.sites) t.built in + (* Every error in the form sent, not the first: [keep_going] checks past a + refused subexpression (see [Check.check]). One error is still raised as + [Loc.Error], which is what every caller of one form expects. *) let program, env, tolerated = - Check.program_tolerant ~tolerate:stale_owner decls + match Check.program_tolerant ~keep_going:true ~tolerate:stale_owner decls with + | r -> r + | exception Loc.Errors [ d ] -> raise (Loc.Error d) in let program = if tolerated = [] then program @@ -1499,6 +1543,15 @@ let shown_names (fn : Tast.fn) : string option array = Array.init n (fun i -> if i < Array.length fn.Tast.snames then fn.Tast.snames.(i) else None) in + (* A name the compiler gave a local of its own, such as the stepper's + [flan~step], is hidden like an unnamed slot: [~] cannot be typed. *) + let raw = + Array.map + (function + | Some n when String.starts_with ~prefix:"flan~" n -> None + | x -> x) + raw + in let stripped = Array.map (Option.map strip_rebind) raw in let count name = Array.fold_left @@ -1543,7 +1596,7 @@ let render_locals ?(origin = "") t ~frame ~(fn : Tast.fn) ~bound let loc = fn.Tast.floc in let extra = ref [] and nslots = ref 0 in let c = - { Render.structs = t.program.Tast.structs; + { Render.structs = t.program.Tast.structs @ Check.fresh_copies t.env t.program.Tast.structs; datas = t.program.Tast.datas; unions = t.program.Tast.unions; enums = Hashtbl.fold (fun k v acc -> (k, v) :: acc) t.env.Check.enums []; @@ -1655,7 +1708,7 @@ let render_condition t ~(st : Tast.structure) : change * (string * string) list let loc = Loc.unknown in let extra = ref [] and nslots = ref 0 in let c = - { Render.structs = t.program.Tast.structs; + { Render.structs = t.program.Tast.structs @ Check.fresh_copies t.env t.program.Tast.structs; datas = t.program.Tast.datas; unions = t.program.Tast.unions; enums = Hashtbl.fold (fun k v acc -> (k, v) :: acc) t.env.Check.enums []; @@ -1916,7 +1969,7 @@ let render_slot ?(origin = "") t ~frame ~(fn : Tast.fn) ~slot ~path | Some name -> let extra = ref [] and nslots = ref 0 in let c = - { Render.structs = t.program.Tast.structs; + { Render.structs = t.program.Tast.structs @ Check.fresh_copies t.env t.program.Tast.structs; datas = t.program.Tast.datas; unions = t.program.Tast.unions; enums = Hashtbl.fold (fun k v acc -> (k, v) :: acc) t.env.Check.enums []; @@ -2233,7 +2286,7 @@ let write_slot ?(origin = "") t ~frame ~(fn : Tast.fn) ~slot ~path in let extra = ref [] and nslots = ref (Array.length base) in let c = - { Render.structs = t.program.Tast.structs; + { Render.structs = t.program.Tast.structs @ Check.fresh_copies t.env t.program.Tast.structs; datas = t.program.Tast.datas; unions = t.program.Tast.unions; enums = @@ -2270,11 +2323,15 @@ let write_slot ?(origin = "") t ~frame ~(fn : Tast.fn) ~slot ~path Array.append bnames (Array.make (List.length !extra) None) } in + (* A struct copy the values named first, laid out in this + module and kept, as [eval_expr] keeps one. *) + let copies = Check.fresh_copies t.env t.program.Tast.structs in let program = { t.program with Tast.fns = t.program.Tast.fns @ fresh @ claim_lifted t lmark tname @ [ thunk ]; + structs = t.program.Tast.structs @ copies; externs = t.program.Tast.externs @ externs } in let ir = @@ -2287,7 +2344,9 @@ let write_slot ?(origin = "") t ~frame ~(fn : Tast.fn) ~slot ~path [eval_expr] says why, and the caller takes the same [held] around this that it takes around one. *) t.program <- - { t.program with Tast.fns = t.program.Tast.fns @ fresh }; + { t.program with + Tast.fns = t.program.Tast.fns @ fresh; + structs = t.program.Tast.structs @ copies }; Ok ({ ir; x86 = t.x86; names = []; fns = []; installs = true; stale = [] }, where, Types.to_string shown.Tast.ty)))) @@ -2359,7 +2418,7 @@ let arm_restart ?(origin = "") t ~index ~(params : Types.t list) in let extra = ref [] and nslots = ref (Array.length base) in let c = - { Render.structs = t.program.Tast.structs; + { Render.structs = t.program.Tast.structs @ Check.fresh_copies t.env t.program.Tast.structs; datas = t.program.Tast.datas; unions = t.program.Tast.unions; enums = Hashtbl.fold (fun k v acc -> (k, v) :: acc) t.env.Check.enums []; @@ -2400,17 +2459,22 @@ let arm_restart ?(origin = "") t ~index ~(params : Types.t list) slots = Array.append base (Array.of_list (List.rev !extra)); snames = Array.append bnames (Array.make (List.length !extra) None) } in + let copies = Check.fresh_copies t.env t.program.Tast.structs in let program = { t.program with Tast.fns = t.program.Tast.fns @ fresh @ claim_lifted t lmark tname @ [ thunk ]; + structs = t.program.Tast.structs @ copies; externs = t.program.Tast.externs @ externs } in let ir = redefinition t ~call:tname program ~fns:(List.map (fun (f : Tast.fn) -> f.Tast.name) fresh @ [ tname ]) in - t.program <- { t.program with Tast.fns = t.program.Tast.fns @ fresh }; + t.program <- + { t.program with + Tast.fns = t.program.Tast.fns @ fresh; + structs = t.program.Tast.structs @ copies }; Ok ({ ir; x86 = t.x86; names = []; fns = []; installs = true; stale = [] }, List.map Types.to_string params) @@ -2443,7 +2507,7 @@ let render_globals ?(origin = "") t ~(globals : Tast.global list) let loc = Loc.unknown in let extra = ref [] and nslots = ref 0 in let c = - { Render.structs = t.program.Tast.structs; + { Render.structs = t.program.Tast.structs @ Check.fresh_copies t.env t.program.Tast.structs; datas = t.program.Tast.datas; unions = t.program.Tast.unions; enums = Hashtbl.fold (fun k v acc -> (k, v) :: acc) t.env.Check.enums []; @@ -2507,7 +2571,68 @@ let render_globals ?(origin = "") t ~(globals : Tast.global list) sticks — a thunk is built and thrown away, so the mark lasts exactly one evaluation, which is the truthful thing for an expression that has no declaration to live in. *) -let eval_expr ?(origin = "") ?(pause = false) t src : change = +(* [frame] is SLIME's eval-in-frame: a stopped frame's index, the function it + is running and which of its slots were bound when it stopped. The + expression is then checked with that frame's named locals in scope — the + innermost of two of one name winning, as it does in the source — and every + use of one reads or writes the frame's own storage through [flan/dev-slot], + so a [set] changes the frame and a vec is not copied. A local not bound + yet is refused where it is named: its address is null. *) +let in_frame t ~frame:(index, (fn : Tast.fn), bound) (parsed : Ast.expr) = + let n = Array.length fn.Tast.slots in + let nparams = List.length fn.Tast.params in + let named = + List.filter_map + (fun i -> + match if i < Array.length fn.Tast.snames then fn.Tast.snames.(i) else None with + | Some raw -> Some (i, strip_rebind raw) + | None -> None) + (List.init n Fun.id) + in + (* Unbound first, so that of two slots one name the bound one shadows. *) + let order = + List.filter (fun (i, _) -> not (List.mem i bound)) named + @ List.filter (fun (i, _) -> List.mem i bound) named + in + let scope = + List.map (fun (i, name) -> (name, fn.Tast.slots.(i), i >= nparams)) order + in + let checked, base, bnames, syn = Check.expression_in_scope t.env ~scope parsed in + let table = List.map2 (fun (i, name) (_, j) -> (j, (i, name))) order syn in + let idx loc k = + { Tast.e = Tast.Int (Int64.of_int k, Types.I64); ty = Types.Int Types.I64; loc } + in + let pointer i loc = + let ty = fn.Tast.slots.(i) in + { Tast.e = + Tast.Prim + (Tast.Cast (Types.Ptr (Types.Mut, ty)), + [ { Tast.e = Tast.Call ("flan/dev-slot", [ idx loc index; idx loc i ]); + ty = Types.Ptr (Types.Mut, Types.Int Types.U8); loc } ]); + ty = Types.Ptr (Types.Mut, ty); loc } + in + let checked = + Tast.rewrite_locals + (fun j loc -> + match List.assoc_opt j table with + | None -> None + | Some (i, name) when not (List.mem i bound) -> + fail loc + "%s is not bound yet where the program stopped, so there is no \ + value to read" name + | Some (i, _) -> Some (pointer i loc)) + checked + in + (* The slots the frame's names were bound to are read through the pointer + now, never directly; a byte keeps each from costing its type's size. *) + let base = + Array.mapi (fun j ty -> if List.mem_assoc j table then Types.Int Types.U8 else ty) base + and bnames = + Array.mapi (fun j nm -> if List.mem_assoc j table then None else nm) bnames + in + (checked, base, bnames) + +let eval_expr ?(origin = "") ?(pause = false) ?frame t src : change = let form = match Source.read_code ~expr:true ~file:origin src with | [ f ] -> f @@ -2526,7 +2651,7 @@ let eval_expr ?(origin = "") ?(pause = false) t src : change = a cold macro module costs its ~300ms before that clock starts, and the non-termination refusals raise [Loc.Error] out of this call, which the daemon already answers as an error rather than a silence. *) - let parsed = Parse.with_imported ~decls:(package_decls t) (macros_for t origin) (fun () -> Parse.expr form) in + let parsed = Parse.with_imported ~decls:(package_decls t) ~fns:(shadowing_fns t origin) (macros_for t origin) (fun () -> Parse.expr form) in (* CIDER's rule: an expression sent from a package's file means what it would mean written in that file, so [(integrate 1.0)] in physics/step.flan reaches [physics/integrate]. The qualification [eval] gives a declaration @@ -2556,7 +2681,11 @@ let eval_expr ?(origin = "") ?(pause = false) t src : change = and the host has no cell for. *) let mark = Check.instance_mark t.env in let lmark = Check.lifted_mark t.env in - let checked, base, bnames = Check.expression t.env parsed in + let checked, base, bnames = + match frame with + | None -> Check.expression t.env parsed + | Some frame -> in_frame t ~frame parsed + in let fresh = Check.instances_since t.env mark in let lifted = Check.lifted_since t.env lmark in (* The thunk's frame starts at whatever [Check.expression] needed and grows @@ -2564,7 +2693,7 @@ let eval_expr ?(origin = "") ?(pause = false) t src : change = appended past [base] and collected here to size the frame below. *) let extra = ref [] and nslots = ref (Array.length base) in let c = - { Render.structs = t.program.Tast.structs; + { Render.structs = t.program.Tast.structs @ Check.fresh_copies t.env t.program.Tast.structs; datas = t.program.Tast.datas; unions = t.program.Tast.unions; enums = Hashtbl.fold (fun k v acc -> (k, v) :: acc) t.env.Check.enums []; @@ -2610,10 +2739,12 @@ let eval_expr ?(origin = "") ?(pause = false) t src : change = let placed = List.filter (fun (f : Tast.fn) -> List.mem f.Tast.name own) placed in + let copies = Check.fresh_copies t.env t.program.Tast.structs in let program = { t.program with Tast.fns = t.program.Tast.fns @ fresh @ placed; - structs = t.program.Tast.structs @ Check.env_structs t.env lifted; + structs = + t.program.Tast.structs @ copies @ Check.env_structs t.env lifted; externs = t.program.Tast.externs @ externs } in let ir = @@ -2639,7 +2770,10 @@ let eval_expr ?(origin = "") ?(pause = false) t src : change = caller closes that half by taking a [held] before this and restoring it when either fails — a copy the session holds and no module defines is a null cell exactly as a stranded declaration is. *) - t.program <- { t.program with Tast.fns = t.program.Tast.fns @ fresh }; + t.program <- + { t.program with + Tast.fns = t.program.Tast.fns @ fresh; + structs = t.program.Tast.structs @ copies }; { ir; x86 = t.x86; names = []; fns = []; installs = true; stale = [] } (* ── What a macro call expands to ──────────────────────────────────── *) @@ -2699,7 +2833,7 @@ let macroexpand ?(origin = "") ~(all : bool) t (src : string) : expansion let before = Expand.quasiquote form in (* And the session's macros in front of it, as [eval] and [eval_expr] both put them: [Macro.program] reads [Parse.imported_macros] directly. *) - Parse.with_imported ~decls:(package_decls t) (macros_for t origin) @@ fun () -> + Parse.with_imported ~decls:(package_decls t) ~fns:(shadowing_fns t origin) (macros_for t origin) @@ fun () -> let after, name = if all then Macro.expand_all before else Macro.expand_step before in diff --git a/lib/shim.ml b/lib/shim.ml index c3070b04..10475b19 100644 --- a/lib/shim.ml +++ b/lib/shim.ml @@ -177,6 +177,106 @@ let prim_cty = function | "bool" -> Some "bool" | _ -> None +(* ── Generic structs ────────────────────────────────────────────────── + A defstruct whose fields introduce [$t] is a template, and C only ever sees + one of its copies: the fields with the arguments written in, laid out the + way [Check] lays the same copy out. The copy is registered here under its + written spelling, [(G u8)], which [ctype_name] turns into a C name. *) + +let sigil n = n <> "" && n.[0] = '$' +let bare n = if sigil n then String.sub n 1 (String.length n - 1) else n + +(* A template's parameters, in the order its fields first introduce them, and + whether each is a length — [Check]'s reading, repeated over the AST + because this runs before [Check] does. *) +let rec template_params ?(fuel = 16) env n = + match Hashtbl.find_opt env.structs n with + | None -> [] + | Some fs -> + let acc = ref [] in + let add m is_len = + if sigil m && not (List.mem_assoc (bare m) !acc) then + acc := (bare m, is_len) :: !acc + in + let rec walk (t : Ast.texpr) = + match t.Ast.t with + | Ast.Tname m -> add m false + | Ast.Tslice (_, e) -> walk e + | Ast.Tarray (Ast.Lname m, e) -> add m true; walk e + | Ast.Tarray (_, e) -> walk e + | Ast.Tmap (k, v) -> walk k; walk v + | Ast.Tapp (h, args) -> + let kinds = + if fuel = 0 || String.equal h n then [] + else List.map snd (template_params ~fuel:(fuel - 1) env h) + in + if List.length kinds = List.length args then + List.iter2 + (fun is_len (a : Ast.texpr) -> + match a.Ast.t with + | Ast.Tname m when is_len -> add m true + | _ -> walk a) + kinds args + else List.iter walk args + | Ast.Tfn (_, ps, r) -> List.iter walk ps; walk r + | Ast.Tlen _ -> () + in + List.iter (fun (f : Ast.field) -> walk f.Ast.fty) fs; + List.rev !acc + +let rec source (t : Ast.texpr) = + match t.Ast.t with + | Ast.Tname n -> n + | Ast.Tlen n -> Int64.to_string n + | Ast.Tapp (n, args) -> + Printf.sprintf "(%s %s)" n (String.concat " " (List.map source args)) + | Ast.Tslice (c, e) -> Printf.sprintf "[%s%s]" (if c then "const " else "") (source e) + | Ast.Tarray (Ast.Lint n, e) -> Printf.sprintf "[%Ld %s]" n (source e) + | Ast.Tarray (Ast.Lname n, e) -> Printf.sprintf "[%s %s]" n (source e) + | Ast.Tmap (k, v) -> Printf.sprintf "(Map %s %s)" (source k) (source v) + | Ast.Tfn (env, ps, r) -> + Printf.sprintf "(%s [%s] %s)" (if env then "Fn" else "CFn") + (String.concat " " (List.map source ps)) (source r) + +(* The copy of template [n] at [args], registered and named. *) +let copy env ~loc n (args : Ast.texpr list) = + let ps = template_params env n in + if List.length ps <> List.length args then + fail loc "%s takes %d argument%s, and this gives %d" n (List.length ps) + (if List.length ps = 1 then "" else "s") (List.length args); + let key = source { Ast.t = Ast.Tapp (n, args); tloc = loc } in + if not (Hashtbl.mem env.structs key) then begin + let sub = List.combine (List.map fst ps) args in + let rec go (t : Ast.texpr) = + let k = + match t.Ast.t with + | Ast.Tname m when List.mem_assoc (bare m) sub -> + (List.assoc (bare m) sub).Ast.t + | Ast.Tname _ | Ast.Tlen _ -> t.Ast.t + | Ast.Tslice (c, e) -> Ast.Tslice (c, go e) + | Ast.Tarray (Ast.Lname m, e) when List.mem_assoc (bare m) sub -> + let l = + match (List.assoc (bare m) sub).Ast.t with + | Ast.Tlen k -> Ast.Lint k + | Ast.Tname c -> Ast.Lname c + | _ -> fail loc "%s's $%s is a length" n (bare m) + in + Ast.Tarray (l, go e) + | Ast.Tarray (l, e) -> Ast.Tarray (l, go e) + | Ast.Tmap (k, v) -> Ast.Tmap (go k, go v) + | Ast.Tapp (h, a) -> Ast.Tapp (h, List.map go a) + | Ast.Tfn (b, ps, r) -> Ast.Tfn (b, List.map go ps, go r) + in + { t with Ast.t = k } + in + Hashtbl.replace env.structs key + (List.map (fun (f : Ast.field) -> { f with Ast.fty = go f.Ast.fty }) + (Hashtbl.find env.structs n)) + end; + key + +let is_template env n = template_params env n <> [] + (* [needed] collects the structs whose typedefs this signature pulls in, in the order they were first met. Order is the program's and never a hash fold's: the object cache keys on the generated text, so a reordering would be a @@ -184,6 +284,14 @@ let prim_cty = function let rec cty env ~needed ~loc ~what (t : Ast.texpr) : string = let t = unalias env t in match t.Ast.t with + | Ast.Tname n when Hashtbl.mem env.structs n && is_template env n -> + fail loc "%s is %s, a generic struct, which is a type only at its \ + arguments — write them, as in (%s %s)" what n n + (String.concat " " + (List.map (fun (_, l) -> if l then "8" else "i32") + (template_params env n))) + | Ast.Tapp (n, args) when Hashtbl.mem env.structs n && is_template env n -> + cty env ~needed ~loc ~what { t with Ast.t = Ast.Tname (copy env ~loc n args) } | Ast.Tname n -> (match prim_cty n with | Some c -> c @@ -256,6 +364,7 @@ let rec cty env ~needed ~loc ~what (t : Ast.texpr) : string = fail loc "%s is a function type, and a C callback is not implemented" what | Ast.Tapp (n, _) -> fail loc "%s is %s, which is not a type this shim generator knows" what n + | Ast.Tlen n -> fail loc "%s is %Ld, which is not a type" what n (* ── What one parameter does at the boundary ────────────────────────── *) @@ -268,6 +377,14 @@ let classify env ~needed ~loc ~what (t : Ast.texpr) = let t' = unalias env t in match t'.Ast.t with | Ast.Tname "string" -> (Pstr, "const char *") + (* A copy crosses behind a pointer only: by value, the Flan half this + generator writes would have to spell the copy's type, and it builds its + wrapper from struct names. *) + | Ast.Tapp (n, _) when Hashtbl.mem env.structs n && is_template env n -> + fail loc + "%s is %s, a generic struct's copy, which crosses to C behind a pointer \ + only — declare (Ptr %s) and let the C side read it" + what (source t') (source t') | Ast.Tname n when Hashtbl.mem env.structs n -> ignore (cty env ~needed ~loc ~what t'); (Pstruct n, ctype_name n) @@ -545,6 +662,8 @@ let typedefs env needed = (fun (f : Ast.field) -> match (unalias env f.Ast.fty).Ast.t with | Ast.Tname m when Hashtbl.mem env.structs m -> define m + | Ast.Tapp (m, args) when Hashtbl.mem env.structs m && is_template env m -> + define (copy env ~loc:f.Ast.floc m args) | _ -> ()) fs; Printf.bprintf b "struct %s_s { /* %s */\n" (ctype_name n) n; diff --git a/lib/tast.ml b/lib/tast.ml index 5267488e..f165c8cc 100644 --- a/lib/tast.ml +++ b/lib/tast.ml @@ -506,6 +506,65 @@ and walk_place f (p : place) = | Pfield (t, _) | Pderef t -> walk f t | Pindex (t, idx) -> walk f t; List.iter (walk f) idx +(* [e] with every read, store and address of a local slot [f] answers for + replaced: a read of slot [i] by [Deref p], its place by [Pderef p], where + [f i loc] is [Some p], a pointer to where the value really lives. The one + caller is evaluating in a stopped frame, whose locals are the other frame's + slots reached by address. Slots [f] answers [None] for are left alone, and + so is every binder: only the slots [f] names are replaced, and none of them + is bound inside [e]. *) +let rec rewrite_locals (f : int -> Loc.t -> expr option) (e : expr) : expr = + let go = rewrite_locals f in + let gos = List.map go in + let kind = + match e.e with + | Local i -> + (match f i e.loc with Some p -> Deref p | None -> e.e) + | Int _ | Float _ | Bool _ | Str _ | Unit | Zero _ | Uninit _ | Global _ + | None_ | FnAddr _ | Break _ | Continue _ -> e.e + | Fill (t, b) -> Fill (t, go b) + | DeadBeef (t, b) -> DeadBeef (t, go b) + | Prim (p, es) -> Prim (p, gos es) + | Call (n, es) -> Call (n, gos es) + | Do es -> Do (gos es) + | Make (n, es) -> Make (n, gos es) + | MakeCase (d, c, es) -> MakeCase (d, c, gos es) + | Arr es -> Arr (gos es) + | InvokeRestart (a, b, es, c, d, l) -> InvokeRestart (a, b, gos es, c, d, l) + | CallPtr (c, es) -> CallPtr (go c, gos es) + | Let (bs, body) -> Let (List.map (fun (s, v) -> (s, go v)) bs, gos body) + | If (a, b, c) -> If (go a, go b, go c) + | While (c, body, latch) -> While (go c, gos body, gos latch) + | Return v -> Return (Option.map go v) + | Set (p, v) -> Set (rewrite_place f e.loc p, go v) + | Addr p -> Addr (rewrite_place f e.loc p) + | Field (t, i) -> Field (go t, i) + | Deref t -> Deref (go t) + | CaseField (t, c, i) -> CaseField (go t, c, i) + | Some_ t -> Some_ (go t) + | UnwrapSome t -> UnwrapSome (go t) + | Signal (k, d, t) -> Signal (k, d, go t) + | Closure (r, t) -> Closure (r, go t) + | Thicken (n, t) -> Thicken (n, go t) + | Match (sc, arms) -> + Match (go sc, List.map (fun a -> { a with abody = gos a.abody }) arms) + | Handled (hs, body) -> + Handled + (List.map (fun h -> { h with henv = Option.map go h.henv }) hs, gos body) + | RestartCase (cs, body) -> + RestartCase (List.map (fun c -> { c with rbody = gos c.rbody }) cs, go body) + | WithAlloc (a, body) -> WithAlloc (go a, gos body) + in + { e with e = kind } + +and rewrite_place f loc (p : place) : place = + match p with + | Plocal i -> (match f i loc with Some ptr -> Pderef ptr | None -> p) + | Pglobal _ -> p + | Pfield (t, i) -> Pfield (rewrite_locals f t, i) + | Pderef t -> Pderef (rewrite_locals f t) + | Pindex (t, idx) -> Pindex (rewrite_locals f t, List.map (rewrite_locals f) idx) + (* ── What the object image can hold ─────────────────────────────────── *) (* Whether an initialiser is a value a linker can write into the program's diff --git a/lib/types.ml b/lib/types.ml index 3513621f..a6f25857 100644 --- a/lib/types.ml +++ b/lib/types.ml @@ -106,6 +106,15 @@ type t = | Fn of t list * t (* (Fn [T ...] R) *) | CFn of t list * t (* (CFn [T ...] R) *) | Var of string (* a type variable — milestone 5 *) + (* The two halves of a length parameter, and neither is the type of a value. + [Len] is a length standing where a generic struct's argument goes — the 8 + in (Small 8 i32) — and what a length variable is bound to. [LArray] is a + fixed array whose length is a variable, [[$n $t]], and exists only in a + generic signature, as the pattern a call site binds [n] from. A generic + body is checked with its lengths at [Check.abstract_len], so neither ever + reaches a backend. *) + | Len of int64 + | LArray of string * t (* [dyn]: one machine word whose contents the runtime knows and this module does not. It is a written type — [(defonce x dyn 5)] boxes the 5 — and it is also what an unannotated [defn] parameter means, which is why it is a @@ -206,8 +215,29 @@ let rec equal a b = && List.for_all2 equal ps ps' && equal r r' | Var x, Var y -> String.equal x y + | Len x, Len y -> Int64.equal x y + | LArray (n, x), LArray (m, y) -> String.equal n m && equal x y | _ -> false +(* How a generic struct's copy is spelled to a reader. The copy is an + ordinary struct under a symbol-safe key — [Small-8-i32] — and this is the + key's written form, [(Small 8 i32)], filled in as each copy is made. Global + rather than on a checker's env because every message that prints a type + comes through here with no env in hand. The key determines the spelling, + so an entry left from an earlier program in the same process is wrong only + for a struct that program's successor declares under a copy's key by hand, + and then only in how a message spells it. *) +let display : (string, string) Hashtbl.t = Hashtbl.create 16 + +(* A struct's name as a printed value's head: its own name, or for a generic + struct's copy the template and its arguments, [Pair i32] — so a value + prints as [(Pair i32 {.a 1 .b 2})], the way its type is written. *) +let struct_head n = + match Hashtbl.find_opt display n with + | Some d when String.length d >= 2 && d.[0] = '(' -> + String.sub d 1 (String.length d - 2) + | _ -> n + let rec to_string = function | Int k -> ikind_name k | Float k -> fkind_name k @@ -215,7 +245,8 @@ let rec to_string = function | String -> "string" | Unit -> "()" | Never -> "Never" - | Named n | Enum n -> n + | Named n -> (match Hashtbl.find_opt display n with Some d -> d | None -> n) + | Enum n -> n | Slice (Mut, t) -> "[" ^ to_string t ^ "]" | Slice (Const, t) -> "[const " ^ to_string t ^ "]" | Array (n, t) -> Printf.sprintf "[%Ld %s]" n (to_string t) @@ -231,7 +262,9 @@ let rec to_string = function | CFn (ps, r) -> Printf.sprintf "(CFn [%s] %s)" (String.concat " " (List.map to_string ps)) (to_string r) - | Var n -> n + | Var n -> "$" ^ n + | Len n -> Int64.to_string n + | LArray (n, t) -> Printf.sprintf "[$%s %s]" n (to_string t) | Dyn -> "dyn" let is_numeric = function Int _ | Float _ -> true | _ -> false diff --git a/lib/x86.ml b/lib/x86.ml index 6c474fa7..6b409272 100644 --- a/lib/x86.ml +++ b/lib/x86.ml @@ -491,7 +491,8 @@ let layout_ctx ~checks ~dev (p : Tast.program) : Emit.m = globals; externs = Hashtbl.create 1; checks; dev; gcfn = dev || Emit.makes_closures p; known = (fun _ -> true); dbg = None; sanitize = false; ann = false; - nstr = 0; nfi = 0; descs = Hashtbl.create 8; fsigs = Emit.fsigs_of p } + nstr = 0; pool = false; nfi = 0; descs = Hashtbl.create 8; + fsigs = Emit.fsigs_of p } let sizeof md t = fst (Emit.lay md t) @@ -532,6 +533,7 @@ let is_agg (t : Types.t) = the arithmetic. *) | Types.Dyn -> false | Types.Var v -> unsupported "type variable %s" v + | Types.Len _ | Types.LArray _ -> unsupported "length variable" let is_void (t : Types.t) = match t with Types.Unit | Types.Never -> true | _ -> false let is_float (t : Types.t) = match t with Types.Float _ -> true | _ -> false @@ -1812,6 +1814,16 @@ and lower_at f (e : Tast.expr) (dst : loc) : unit = let l = float_const f x ~f64 in fload f.b ~dst:xmm0 ~mm:(Sym (l, 0)) ~f64; fstore f.b ~src:xmm0 ~mm:(lmem f dst ~scratch:r11) ~f64 + | Tast.Str s when f.md.Emit.pool -> + (* [Emit]'s [pool]: an expression thunk's literal is a copy the process + keeps, so nothing is left pointing into the module. *) + let l, n = fi_bytes f s in + lea f.b ~dst:rdi ~mm:(Sym (l, 0)); + imm_into f ~reg:rsi (Int64.of_int n); + call_sym f.b "flan_dev_literal"; + store_int f.b ~src:rax ~mm:(lmem f dst ~scratch:r11) ~size:8; + imm_into f ~reg:rax (Int64.of_int n); + store_int f.b ~src:rax ~mm:(lmem f (shift dst 8) ~scratch:r11) ~size:8 | Tast.Str s -> (* A string and a [u8] slice are the same two words, which is why [Bytes] below is a non-instruction. *) @@ -1916,6 +1928,9 @@ and lower_at f (e : Tast.expr) (dst : loc) : unit = | Types.Fn _ -> Some (Aint (shift c 8, Types.Ptr (Types.Mut, Types.Unit))) | _ -> None in + (match callee.Tast.ty with + | Types.CFn _ -> null_check f e.Tast.loc callee.Tast.ty c + | _ -> ()); call_flan f ?env ~at:e.Tast.loc ~target:(`Loc c) ~args ~rty:t dst | Tast.Do body -> block f body dst t | Tast.Let (bs, body) -> @@ -2702,6 +2717,26 @@ and elements f (base : loc) (ty : Types.t) (is : Tast.expr list) : loc = That is also the answer to "does a bounds trap run defers": an answered one does, because it leaves through the innermost pad; an unanswered one still does not, because it is a die inside C. Identical on both backends. *) +(* [Emit.null_check]: a (CFn ...) holding null is not called. Tested before + the arguments, as the LLVM backend does, and [flan_null_call] returns only + when something transferred. *) +and null_check f (loc : Loc.t) ty (c : loc) = + load_loc f ~reg:rax c ty; + test_rr f.b ~a:rax ~c:rax; + let ok = new_label f "fnok" in + jcc_lbl f.b ~cc:cc_ne ok; + note f "A null (CFn ...): the site, the type as a C string and the channel."; + str_args f ~preg:rdi ~nreg:rsi (Loc.to_string loc); + let tys, _ = fi_bytes f (Types.to_string ty ^ "\000") in + lea f.b ~dst:rdx ~mm:(Sym (tys, 0)); + chan_into f ~reg:rcx; + mark_at f loc; + xor_rr f.b ~dst:rax ~src:rax; + call_sym f.b "flan_null_call"; + guard f; + ud2 f.b; + lbl f.b ok + and bounds_call f sym (loc : Loc.t) (extra : int list) = note f (Printf.sprintf "Out of bounds: the location string, the operands, and this frame's channel, \ @@ -5316,6 +5351,7 @@ let redefinition ~checks ?(dev = true) ?(known = fun _ -> true) p.Tast.globals in let md = layout_ctx ~checks ~dev p in + md.Emit.pool <- call <> None && retains; let externs = Hashtbl.create 16 in List.iter (fun (e : Tast.extern) -> Hashtbl.replace externs e.Tast.ename e.Tast.esym) @@ -5420,7 +5456,10 @@ let redefinition ~checks ?(dev = true) ?(known = fun _ -> true) the same and [test_reload.ml] checks it there by grepping the IR text; there is no text to grep on this side, so the guarantee is this loop order and this comment. *) - let cstr sym = let l = string_const f sym in lea f.b ~dst:rdi ~mm:(Sym (l, 0)) in + (* Not counted in [nstr]: flan_dev.c's registry copies a name it keeps, so + nothing is left pointing at these once the lookup returns. Counted, every + module after the session's first new name would keep its mapping. *) + let cstr sym = let l = fi_cstring f sym in lea f.b ~dst:rdi ~mm:(Sym (l, 0)) in List.iter (fun (fn : Tast.fn) -> cstr (Mangle.sym fn.Tast.name); @@ -5599,16 +5638,14 @@ let redefinition ~checks ?(dev = true) ?(known = fun _ -> true) store one anywhere it likes -- [(set msg "tuned")] on a string global leaves that global pointing into the mapping the agent is about to drop. The next thunk can be mapped at the same address, so the result is silent - garbage rather than a fault. A module with no string constants has nothing - in its image anyone could still be pointing at; one with any keeps its - mapping, which costs a page and is the same bargain every redefinition - already makes. [string_const] is where the count is kept, and the install - function's own registry names go through it too -- which is right rather - than incidental, since a module that interned a name left something - behind. *) + garbage rather than a fault. So a thunk's literal is a copy the process + keeps ([Emit]'s [pool]) and is not counted; what [string_const] still + counts is a constant something may go on pointing at, such as a + condition's name, and a module with one keeps its mapping. The install + function's registry names are not counted: the registry copies them. *) (match call with | Some fn - when fns = [ fn ] && consts = [] + when fns = [ fn ] && consts = [] && not (Emit.thunk_makes_fn_values p fn) && ((not retains) || md.Emit.nstr = 0) -> Buffer.add_string out "\n\t.data\n\t.globl\tflan_reload_transient\n\ diff --git a/plan.org b/plan.org index cc973a99..4e49ecb5 100644 --- a/plan.org +++ b/plan.org @@ -248,11 +248,12 @@ and on a managed ~class~ instance. An ordinary ~struct~ never carries one. already refused so nothing else it could be. ~sort~ declares ~ordered?~ of its variable, the abstract pass then allows ~<~ in the body, and each instantiation checks the concrete type satisfies the predicate and refuses the call site if it - does not. There are *five* predicates — ~ordered?~, ~equal?~, ~hashable?~, - ~numeric?~, ~integer?~ — against Odin's forty-one, and they entail one another - in one direction, so one clause usually does: ~integer?~ gives ~numeric?~, - ~numeric?~ gives ~ordered?~, and ~ordered?~ gives ~equal?~. ~integer?~ exists - because ~numeric?~ admits floats. + does not. There are *six* predicates — ~ordered?~, ~equal?~, ~hashable?~, + ~numeric?~, ~integer?~, ~enum?~ — against Odin's forty-one, and they entail one + another in one direction, so one clause usually does: ~integer?~ gives + ~numeric?~, ~numeric?~ gives ~ordered?~, and ~ordered?~ gives ~equal?~. + ~integer?~ exists because ~numeric?~ admits floats. ~enum?~ gives ~ordered?~ + and a conversion to a number, and not arithmetic. ~hashable?~ is what lets a variable *key a map*: without it the type ~(Map $t i32)~ is refused where it is written, and with it the refusal moves to the call site that names an unhashable key. diff --git a/runtime/flan_dev.c b/runtime/flan_dev.c index 245541a0..e096961d 100644 --- a/runtime/flan_dev.c +++ b/runtime/flan_dev.c @@ -436,6 +436,56 @@ void flan_dev_result_end(void) { * when it was sizing something to send through a socket. */ uint64_t flan_dev_result_cap(void) { return RESULT_MAX; } +/* ── An expression thunk's string literals ──────────────────────────── */ + +/* A literal in an evaluated expression is a copy made here and kept for the + * life of the process, one per distinct text, NUL after the bytes as the + * module's own constants have. The expression may store it anywhere, so + * pointing it into the thunk's module would keep that module mapped for ever + * (Emit's [pool]); pointing it here lets the agent unload the module once the + * thunk returns. Game thread only: thunks run there. */ +typedef struct lit { struct lit *next; int64_t len; uint8_t bytes[]; } lit; + +static lit **lits; +static size_t lits_cap, lits_n; + +static uint64_t lit_hash(const uint8_t *p, int64_t n) { + uint64_t h = 1469598103934665603ULL; /* FNV-1a */ + for (int64_t i = 0; i < n; i++) { h ^= p[i]; h *= 1099511628211ULL; } + return h; +} + +const uint8_t *flan_dev_literal(const uint8_t *p, int64_t n) { + if (n < 0) n = 0; + if (lits_n >= lits_cap / 2) { + size_t cap = lits_cap ? lits_cap * 2 : 64; + lit **t = calloc(cap, sizeof *t); + if (t == NULL) die("out of memory", "a string literal"); + for (size_t i = 0; i < lits_cap; i++) + for (lit *e = lits[i], *nx; e != NULL; e = nx) { + nx = e->next; + size_t b = lit_hash(e->bytes, e->len) & (cap - 1); + e->next = t[b]; + t[b] = e; + } + free(lits); + lits = t; + lits_cap = cap; + } + size_t b = lit_hash(p, n) & (lits_cap - 1); + for (lit *e = lits[b]; e != NULL; e = e->next) + if (e->len == n && memcmp(e->bytes, p, (size_t)n) == 0) return e->bytes; + lit *e = malloc(sizeof *e + (size_t)n + 1); + if (e == NULL) die("out of memory", "a string literal"); + e->len = n; + if (n > 0) memcpy(e->bytes, p, (size_t)n); + e->bytes[n] = 0; + e->next = lits[b]; + lits[b] = e; + lits_n++; + return e->bytes; +} + /* Called between the copy and the second read of the counter, when set. It * exists for test/dev_limits.c and nothing else sets it: the losing side of * the race is a write landing inside that window, and a second thread cannot @@ -1213,6 +1263,14 @@ typedef struct { int64_t seq; /* when it was made */ int64_t died; /* when it was released, or 0 while it is live */ uint64_t gen; /* this slot's own seqlock; odd while it is written */ + /* The allocator the block came from, where the note knew it — a Vec's, or + * the temp arena's — and NULL where it did not. (free s) on a slice asks + * it, so a block is never handed to an allocator it did not come from. */ + const void *owner; + /* Set for a block handed out as a slice — (bytes s), (clone xs), a + * formatted number — and clear for a Vec's or a Map's storage, which only + * their own free releases. */ + int32_t sliced; } flan_reg_entry; /* ── Why this table has a seqlock and the watch table's is the model ─── @@ -1505,6 +1563,8 @@ static void flan_reg_compact(void) { e->type = old[i].type; e->typelen = old[i].typelen; e->base = old[i].base; e->bytes = old[i].bytes; e->elem = old[i].elem; e->seq = old[i].seq; e->died = old[i].died; + e->owner = old[i].owner; + e->sliced = old[i].sliced; flan_reg_end(e); flan_reg_used++; break; @@ -1518,8 +1578,31 @@ static void flan_reg_compact(void) { /* One note per allocation. [base] replaces whatever was recorded there, live * or dead: the allocator handing out an address is the event that makes any * older answer about it wrong. */ +static void flan_reg_note_full(void *base, int64_t bytes, int64_t elem, + const char *type, int64_t typelen, + const void *owner, int32_t sliced); + void flan_dev_reg_note(void *base, int64_t bytes, int64_t elem, const char *type, int64_t typelen) { + flan_reg_note_full(base, bytes, elem, type, typelen, NULL, 0); +} + +void flan_dev_reg_note_owned(void *base, int64_t bytes, int64_t elem, + const char *type, int64_t typelen, + const void *owner) { + flan_reg_note_full(base, bytes, elem, type, typelen, owner, 0); +} + +/* A block handed out as a slice, which (free s) may release. */ +void flan_dev_reg_note_sliced(void *base, int64_t bytes, int64_t elem, + const char *type, int64_t typelen, + const void *owner) { + flan_reg_note_full(base, bytes, elem, type, typelen, owner, 1); +} + +static void flan_reg_note_full(void *base, int64_t bytes, int64_t elem, + const char *type, int64_t typelen, + const void *owner, int32_t sliced) { uintptr_t a = (uintptr_t)base; size_t s; int64_t probe; @@ -1549,6 +1632,8 @@ void flan_dev_reg_note(void *base, int64_t bytes, int64_t elem, flan_reg[j].elem = elem; flan_reg[j].seq = ++flan_reg_seq; flan_reg[j].died = 0; + flan_reg[j].owner = owner; + flan_reg[j].sliced = sliced; flan_reg_end(&flan_reg[j]); return; } @@ -1575,6 +1660,31 @@ void flan_dev_reg_note(void *base, int64_t bytes, int64_t elem, int flan_dev_reg_overflowed(void) { return flan_reg_full; } +/* (free s) on a slice, asked before the block is handed back: 0 when it may + * go to [owner] — or when the registry cannot say, because this is not a dev + * build, the table is full, or the note did not know the allocator — 1 when + * [p] is not the start of a block any allocator handed out, 2 when the block + * came from another allocator (whose record goes to [*found]), 3 when it was + * already released, 4 when it is a Vec's or a Map's storage rather than a + * block handed out as a slice. */ +static flan_reg_entry *flan_reg_find(uintptr_t a); + +int32_t flan_dev_reg_owner_check(const void *p, const void *owner, + const void **found) { + flan_reg_entry *e; + if (!flan_reg_on) return 0; + e = flan_reg_find((uintptr_t)p); + if (e == NULL) return flan_reg_full ? 0 : 1; + if (e->base != (uintptr_t)p) return 1; + if (e->died != 0) return 3; + if (!e->sliced) return 4; + if (e->owner != NULL && e->owner != owner) { + if (found) *found = e->owner; + return 2; + } + return 0; +} + /* The block containing [a], live or dead, or NULL. A linear scan, because the * reader is a person pressing a key and the writer is a game loop: the cost * belongs on this side of the table. */ diff --git a/runtime/flan_rt.c b/runtime/flan_rt.c index a02103e8..8801cff7 100644 --- a/runtime/flan_rt.c +++ b/runtime/flan_rt.c @@ -1538,6 +1538,51 @@ void flan_stale_call(const char *site, const char *callee, const char *want, rt_die(); } +/* ── A call through a null (CFn ...) ─────────────────────────────────── + * + * A (CFn ...) may sit in a struct field, a fixed array or a global, all of + * which zero-initialise, and a zeroed one is a null address. Every call + * through a CFn value tests it first and lands here on null, so the call is + * not made. It signals NullCall with `error` — BoundsError's shape and its + * decision about restarts: no value a handler supplies turns into a function + * to call, so what answers it is a restart the program already has, or the + * break loop in a dev build. + * + * `type` is copied and never freed, for flan_stale_call's reason: the text + * lives in the image of the module that compiled the call, which may be a + * thunk that is unloaded once it returns. Must agree with the prelude's + * (defstruct NullCall :parent Error [type string]). */ + +typedef struct { flan_slice type; } flan_nullcall_cond; + +static const uint8_t flan_nullcall_name[] = "NullCall"; +#define FLAN_NULLCALL_NAMELEN 8 + +static void nullcall_sentence(const char *ty) { + rt_sentence("this call is through a %s that holds no function — a field, " + "an array element or a global of that type starts out empty. " + "Store a function in it before calling it, or hold it as an " + "(Option %s) and match on it", + ty, ty); +} + +void flan_null_call(const uint8_t *loc, int64_t loclen, const char *ty, + void *xfer) { + flan_nullcall_cond c; + flan_condesc d; + uint32_t chain[2]; + c.type = flan_stale_copy(ty); + nullcall_sentence(ty); + rt_condesc(&d, chain, flan_nullcall_name, FLAN_NULLCALL_NAMELEN, loc, + loclen); + flan_signal(&d, &c, xfer); + if (*(void **)xfer != NULL) return; + nullcall_sentence(ty); /* in full; see flan_bounds_signal */ + if (rt_error_break(&d, &c, xfer)) return; + rt_print_sentence(loc, loclen); + rt_die(); +} + /* ── Allocators, spec-memory.md ──────────────────────────────────────── * * One type-erased procedure plus an opaque data pointer, which is Odin's @@ -1677,6 +1722,14 @@ static int flan_over_budget(flan_allocator *a, int64_t size) { */ void flan_dev_reg_note(void *base, int64_t bytes, int64_t elem, const char *type, int64_t typelen); +void flan_dev_reg_note_owned(void *base, int64_t bytes, int64_t elem, + const char *type, int64_t typelen, + const void *owner); +int32_t flan_dev_reg_owner_check(const void *p, const void *owner, + const void **found); +void flan_dev_reg_note_sliced(void *base, int64_t bytes, int64_t elem, + const char *type, int64_t typelen, + const void *owner); void flan_dev_reg_dead(void *base); void flan_dev_reg_dead_range(void *base, int64_t bytes); /* flan_dev.c: a dev build fills a block a resize moved away from, so that a @@ -2481,7 +2534,7 @@ static int8_t flan_temp_text(flan_render render, const void *x, if (!q) return 0; memcpy(q, buf, (size_t)len); } - flan_dev_reg_note(q, len, 1, "u8", 2); + flan_dev_reg_note_sliced(q, len, 1, "u8", 2, a); out->ptr = q; out->len = len; return 1; @@ -2733,6 +2786,50 @@ int8_t flan_bytes_dup(flan_vec *v, flan_allocator *a, const uint8_t *p, return 1; } +/* (free s) on a slice (bytes s) or (clone xs) made: the block goes back to + * [a], the allocator the compiler passes — the context's, or the one named. + * The slice carries no allocator, so a dev build checks the registry first and + * traps on a slice that is not the start of a live block, or on a block from + * another allocator; a release build trusts the program, as Odin's delete + * does. An allocator that cannot free one block keeps it, as flan_vec_free + * does: free-all is how its region is released. */ +_Noreturn static void flan_slice_free_fail(const uint8_t *loc, int64_t loclen, + int32_t why) { + rt_flush_out(); + fprintf(stderr, "%.*s: %s\n", (int)loclen, (const char *)loc, + why == 5 ? "this slice is text in the temp allocator, which is " + "released all at once by (free-temp), not one slice at a " + "time" + : why == 2 ? "this slice's block came from another allocator — free " + "it through the allocator it was made with, (free s a)" + : why == 3 ? "this slice's block was already freed" + : why == 4 ? "this slice views a Vec's or a Map's storage, which " + "only freeing the Vec or the Map releases" + : "this slice is not a block an allocator handed out — " + "only a slice (bytes s) or (clone xs) made can be freed"); + rt_trap((const uint8_t *)"BadFree", 7); +} + +void flan_slice_free(const void *p, int64_t n, int64_t size, int64_t align, + flan_allocator *a, const uint8_t *loc, int64_t loclen) { + int32_t why; + int64_t bytes; + if (p == NULL || n <= 0) return; + if (!a) flan_null_alloc_fail(loc, loclen); + { + const void *found = NULL; + why = flan_dev_reg_owner_check(p, a, &found); + if (why == 2 && found != NULL + && ((flan_allocator *)found)->proc == flan_arena_proc + && ((flan_arena *)((flan_allocator *)found)->data)->grow) + why = 5; + if (why != 0) flan_slice_free_fail(loc, loclen, why); + } + if (!(a->caps & FLAN_CAN_FREE)) return; + if (!flan_mul_bytes(n, size, &bytes)) return; + a->proc(a, FLAN_ALLOC_FREE, (void *)p, bytes, 0, align); +} + int8_t flan_vec_clone(flan_vec *dst, flan_vec *src, flan_allocator *a, int64_t size, int64_t align, const uint8_t *loc, int64_t loclen) { @@ -3660,9 +3757,18 @@ int8_t flan_map_clone(flan_map *dst, flan_map *src, flan_allocator *a, * A container with no storage yet notes nothing: flan_dev_reg_note ignores a * null base, so an empty Vec needs no branch on this side. */ +/* The note for a (bytes s) or (clone xs) block: the hidden Vec that made it, + * marked as a block handed out as a slice. */ +void flan_dev_reg_note_slice(flan_vec *v, int64_t size, const char *type, + int64_t typelen) { + if (v) flan_dev_reg_note_sliced(v->ptr, v->cap * size, size, type, typelen, + v->alloc); +} + void flan_dev_reg_note_vec(flan_vec *v, int64_t size, const char *type, int64_t typelen) { - if (v) flan_dev_reg_note(v->ptr, v->cap * size, size, type, typelen); + if (v) flan_dev_reg_note_owned(v->ptr, v->cap * size, size, type, typelen, + v->alloc); } void flan_dev_reg_note_map(flan_map *m, int64_t ksize, int64_t vsize, diff --git a/spec-memory.md b/spec-memory.md index c06db1cd..1701ed4c 100644 --- a/spec-memory.md +++ b/spec-memory.md @@ -268,12 +268,14 @@ instantiates it: > field-free storage. It does **not** support `=`, `<`, `+`, or `hash`. What makes that liveable is a `where` clause of compile-time type predicates, -written as a map at the head of the body. There are five — `ordered?`, -`equal?`, `hashable?`, `numeric?`, `integer?` — they are not type classes +written as a map at the head of the body. There are six — `ordered?`, +`equal?`, `hashable?`, `numeric?`, `integer?`, `enum?` — they are not type classes because a predicate carries no implementations and merely gates a builtin the compiler already has, and they entail one another in one direction, so one clause usually does: `integer?` admits every integer kind and no float, and entails `numeric?`, which entails `ordered?`, which entails `equal?`. +`enum?` admits exactly the enums and entails `ordered?` and `equal?`, not +`numeric?`. `integer?` is what admits the bitwise operators, the shifts and an integer-only body like `abs`'s — under `numeric?` those bodies would be instantiated at the floats too (TODO.org, "abs is one generic, and a bound joins @@ -354,14 +356,14 @@ where the type is written, so neither is refused at the variable. A conversion was never a claim that the value survives. The conversion *to* an enum needs `integer?` exactly, because an enum is an `i32` and a float has no enum reading, and `numeric?` would admit an `f32` copy the concrete rule refuses. +The conversion *from* an enum to a number needs `enum?` or `numeric?`, and +its refusal names both. `ordered?`, `equal?` and `hashable?` admit no conversion at all: they say what can be compared or keyed, not what is a number — and that is a claim about what the predicate says, not about the set it denotes today, which currently does admit only numbers and enums. The refusal names the predicate to write (TODO.org, "A conversion is legal at a bounded variable when it is legal at every -type the bound admits"). One consequence is recorded as open: no predicate now -licenses a generic enum → integer conversion (TODO.org, "There is now no generic -enum to integer conversion"). +type the bound admits"). **A type variable is not instantiated at `dyn`.** Two models answer "one body, many types" and they are not rivals: this one copies per written type at diff --git a/spec-syntax.md b/spec-syntax.md index 5f7fc527..85fa555e 100644 --- a/spec-syntax.md +++ b/spec-syntax.md @@ -155,8 +155,9 @@ Each item: the proposal, then the reason in one line. `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. **Built** - (also `-=`, `*=`, `/=`). + `(set x (+ x v))` where every part of the place is a name or a literal, and + `(update x + v)` otherwise, so the place is evaluated once either way, as + with `++`. **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 diff --git a/test/dune b/test/dune index 81b2a2a0..87b732d4 100644 --- a/test/dune +++ b/test/dune @@ -140,7 +140,9 @@ ; a Flan program: flan_dyn.c has no Flan spelling yet. It is also the one ; translation unit here that frees the most, which is what makes it worth a ; sanitized run at all. See [dyn_sweep]. - (file dyn_ops.c)) + (file dyn_ops.c) + ; [dev_session] drives a real flan dev --sanitize. + (file %{workspace_root}/bin/main.exe)) (action (run ./test_sanitize.exe))) ; The corpus a third time, under Valgrind's memcheck. Its own alias for the diff --git a/test/programs/bytes-copy.flan b/test/programs/bytes-copy.flan index 8084f2a5..d198c27b 100644 --- a/test/programs/bytes-copy.flan +++ b/test/programs/bytes-copy.flan @@ -14,13 +14,17 @@ b (bytes s)] (set (at b 0) \Z) (println (string b)) ; ZNSERTIONSORT - (println s)) ; INSERTIONSORT + (println s) ; INSERTIONSORT + ;; The copy's block came from the context allocator, and free hands it + ;; back there — which is what keeps this program leak-free. + (free b)) ;; 2. A literal's copy is writable — the exact form that used to segfault ;; at -O0 and silently do nothing at -O2. (let [b (bytes "hi")] (set (at b 0) \H) - (println (string b))) ; Hi + (println (string b)) ; Hi + (free b)) ;; 3. The view still costs nothing and reads the string's own storage. (let [v (bytes-view "abc")] @@ -35,4 +39,10 @@ (println (string b))) ; arenA (free-all frame) (arena-destroy frame) + + ;; 5. (clone xs) with no allocator is the context's too, and free releases + ;; it the same way. + (let [c (clone (slice [1 2 3]))] + (println (at c 2)) ; 3 + (free c)) 0) diff --git a/test/programs/dev-break-nullcall.flan b/test/programs/dev-break-nullcall.flan new file mode 100644 index 00000000..47de55f7 --- /dev/null +++ b/test/programs/dev-break-nullcall.flan @@ -0,0 +1,26 @@ +;;;; A program that stops on a call through a null CFn, for driving the break +;;;; loop over one. Nothing handles NullCall here, so the signal reaches the +;;;; break hook and the program parks, as a bad index does in +;;;; dev-break-bounds.flan; the program's own continue is the way on. +(import agent "vendor:agent") + +(defonce table [2 (CFn [i32] i32)]) +(defonce skipped i64) +(defonce ticks i64) + +(defn call-slot [i i32] i32 ((at table i) 5)) + +(defn frame [i i32] () + (restart-case + (do (println (call-slot i)) (println "frame done")) + (continue [] (set skipped (+ skipped 1))))) + +(defn main [] i32 + (agent/start "/tmp/flan-dev-break-nullcall-fallback.sock") + ;; Slot 1 was never set, so it is null. + (frame 1) + (print skipped) (println "") + (dotimes [i 4000] + (agent/wait 5) + (set ticks (+ ticks 1))) + 0) diff --git a/test/programs/dev-inspect.flan b/test/programs/dev-inspect.flan index 81a65af3..85a30c54 100644 --- a/test/programs/dev-inspect.flan +++ b/test/programs/dev-inspect.flan @@ -11,8 +11,10 @@ ;;;; The other locals are the shapes a path step has to walk and that an ;;;; expression cannot reach at all: an option's payload, which has no ;;;; accessor form in the language, and a union case's field, whose offset -;;;; depends on which case the value is in. +;;;; depends on which case the value is in. And a local of a package's type, +;;;; which is named as the checker names it everywhere else: qualified. (import agent "vendor:agent") +(import shape "pkgs/shape") (defstruct Point [x f32 y f32]) (defstruct Boom [why i32]) @@ -38,7 +40,8 @@ (let [mark (Point {.x 1.5 .y 2.5}) xs [10 20 30] box (Some (Point {.x 4.5 .y 5.5})) - s (Shape.Rect {.w 3 .h 6})] + s (Shape.Rect {.w 3 .h 6}) + pk (shape/box 3 4)] (deeper))) (defonce ticks i64) diff --git a/test/programs/dev-own-break.flan b/test/programs/dev-own-break.flan new file mode 100644 index 00000000..a7de2a59 --- /dev/null +++ b/test/programs/dev-own-break.flan @@ -0,0 +1,22 @@ +;;;; A program that stops on its own while an evaluation is in flight. +;;;; +;;;; Setting [go] from the editor starts it: the loop sees it, sleeps without +;;;; polling for longer than a module takes to build, and then signals. An +;;;; expression evaluated just after [go] is therefore waiting in the ring +;;;; when the program's own break is entered, and runs inside that break's +;;;; loop. The stop is the program's and the value is the expression's. +(import agent "vendor:agent") + +(declare-c usleep [us i32] i32 "usleep") + +(defstruct Late []) + +(defonce go i64) + +(defn main [] i32 + (while (= go 0) + (agent/wait 5)) + (usleep 1500000) + (restart-case + (do (error (Late {})) 0) + (carry-on [] 0))) diff --git a/test/programs/dyn-if-truthy.flan b/test/programs/dyn-if-truthy.flan index 609447c2..928162fd 100644 --- a/test/programs/dyn-if-truthy.flan +++ b/test/programs/dyn-if-truthy.flan @@ -92,6 +92,13 @@ ;; used to trap trying to unbox "x" as a strict bool. (println (or (box nil) (box "x"))) (println (or (box 5) (box "unreached"))) + ;; A typed bool operand beside a dyn one: the two meet at dyn, the bool + ;; boxed, so the dyn one comes back whichever side of the if it lands on. + (println (or false (box "s"))) + (println (or (= 1 2) (box nil))) + (println (and (box nil) (= 1 1))) + (println (and true (box "y"))) + (println (or true (box "unreached"))) ;; One operand is that operand, whatever it is -- no test, no sentinel. (println (and (box nil))) diff --git a/test/programs/enum-generic.flan b/test/programs/enum-generic.flan new file mode 100644 index 00000000..6de559ff --- /dev/null +++ b/test/programs/enum-generic.flan @@ -0,0 +1,28 @@ +;;;; A generic conversion from an enum, licensed by {:where (enum? $t)}. enum? +;;;; admits exactly the enums and entails ordered? and equal?, so a body under +;;;; it may convert, compare and test for equality, at any enum. + +(defenum Color [red green blue]) +(defenum Size [small 10 large 20]) + +(defn code [x $t] i32 + {:where (enum? $t)} + (i32 x)) + +(defn later? [a $t b $t] bool + {:where (enum? $t)} + (> a b)) + +(defn same? [a $t b $t] bool + {:where (enum? $t)} + (and (= a b) (<= a b))) + +(defn main [] i32 + (let [c (Color 2) + s (Size 20)] + (println (code c)) ; 2 + (println (code s)) ; 20 + (println (later? c (Color 0))) ; true + (println (same? (Color 1) (Color 1))) ; true + (println (f64 (code s)))) ; 20 + 0) diff --git a/test/programs/fn-cfn-table.flan b/test/programs/fn-cfn-table.flan new file mode 100644 index 00000000..3d796620 --- /dev/null +++ b/test/programs/fn-cfn-table.flan @@ -0,0 +1,55 @@ +;; A (CFn ...) in the places that zero-initialise: a struct field, a fixed +;; array's element and a global. A table of bare code addresses is what the +;; narrow function type is for, and the zero is the only objection there ever +;; was — a zeroed CFn is a null address. So a call through one tests it first +;; and signals NullCall rather than jumping to nothing. +;; +;; With no argument the empty calls are answered and the program carries on; +;; with "1" nothing answers and it dies, with the site and the type. + +(defn double [x i32] i32 (* x 2)) +(defn negate [x i32] i32 (- 0 x)) + +(defstruct Ops [name string run (CFn [i32] i32)]) + +(defonce table [3 (CFn [i32] i32)]) +(defonce hook (CFn [i32] i32)) +(defonce evaluated i32 0) +(defonce caught i32 0) +(defonce seen string "") + +(defn arg [x i32] i32 + (set evaluated (+ evaluated 1)) + x) + +(defn try-call [f (CFn [i32] i32) x i32] () + (restart-case + (do (print (f (arg x))) (println "")) + (continue [] (println "empty")))) + +(defn main [args [string]] i32 + (set (at table 0) double) + (set (at table 2) negate) + (let [ops (Ops {.name "half-built"})] + (if (> (length args) 1) + ;; Unanswered: the process dies at the call. + (do (print ((at table 1) 5)) (println "") 0) + (do + (handler-bind + [(NullCall [c] + (set caught (+ caught 1)) + (set seen (.type c)) + (invoke-restart 'continue))] + (dotimes [i 3] (try-call (at table i) 7)) ; 14, empty, -7 + (try-call (.run ops) 1) ; empty + (try-call hook 2) ; empty + (set hook double) + (try-call hook 2)) ; 4 + ;; The argument of a call that is not made is never evaluated. + (print evaluated) (println "") ; 3 + (print caught) (println "") ; 3 + (println seen) ; (CFn [i32] i32) + ;; And a filled field calls as any CFn does. + (let [full (Ops {.name "full" .run negate})] + (print ((.run full) 9)) (println "")) ; -9 + 0)))) diff --git a/test/programs/fn-in-struct.flan b/test/programs/fn-in-struct.flan index 0baf66ce..bc7ab3dd 100644 --- a/test/programs/fn-in-struct.flan +++ b/test/programs/fn-in-struct.flan @@ -9,10 +9,8 @@ ;; the collector and may be kept anywhere, and (Option (Fn ...)) is the field ;; that holds one — see fn-escape.flan. ;; -;; Which means a (CFn ...) field is refused too, and for the zero alone — -;; a table of function pointers is exactly what that type is for, and nothing -;; about capture stands in its way. An (Option (CFn ...)) field is already -;; legal and is the shape that works; TODO.org, "CFn in a struct or a fixed array", carries the rest as its own item. +;; A (CFn ...) field is not refused: every call through one tests for null and +;; signals NullCall, so its zero is an empty slot — fn-cfn-table.flan. (defstruct Ops [run (Fn [i32] i32)]) (defn main [] i32 0) diff --git a/test/programs/free-slice.flan b/test/programs/free-slice.flan new file mode 100644 index 00000000..537c91f7 --- /dev/null +++ b/test/programs/free-slice.flan @@ -0,0 +1,35 @@ +;;;; (free s) on a slice hands its block back to the context allocator, or to +;;;; the one named. A slice does not carry its allocator, so a dev build checks +;;;; the block against the allocation registry and traps rather than hand one +;;;; allocator another's block. Argument 0 frees correctly both ways; 1 frees +;;;; an arena's copy through the context allocator; 2 frees one copy twice; +;;;; 3 frees a view of an array, which no allocator handed out; 4 frees a +;;;; Vec's storage through a let-bound view of it; 5 frees a formatted +;;;; number's text, which the temp allocator holds. +(defn main [args [string]] i32 + (let [which (if (> (length args) 1) (bytes->i64 (bytes-view (at args 1))) 0) + a (arena-new 4096)] + (cond + (= which 1) (let [b (bytes "arena" a)] (free b)) + (= which 2) (let [b (bytes "twice")] (free b) (free b)) + (= which 3) (let [arr [1 2 3] + s (slice arr)] + (free s)) + (= which 4) (let [v (vec-new i32)] + (push v 1) + (push v 2) + (let [s (slice v)] (free s)) + (println (at v 1)) + (free v)) + (= which 5) (let [t (i64->bytes 42)] (free t)) + :else + (let [b (bytes "heap") + c (bytes "arena" a) + d (clone (slice [1.5 2.5]) (heap-allocator))] + (println (string b) (string c) (at d 1)) + (free b) + (free c a) + (free d (heap-allocator)))) + (println "done") + (arena-destroy a)) + 0) diff --git a/test/programs/generic-struct.flan b/test/programs/generic-struct.flan new file mode 100644 index 00000000..f295fbd8 --- /dev/null +++ b/test/programs/generic-struct.flan @@ -0,0 +1,109 @@ +;;;; Generic structs, end to end: type parameters and length parameters. +;;;; +;;;; A defstruct whose fields introduce $t is a template, and each set of +;;;; arguments it is given is a copy — an ordinary struct. A parameter is a +;;;; length when it stands in an array's length slot, and a type anywhere else; +;;;; the arguments are written in the order the fields first introduce them. +;;;; +;;;; Small is Odin's Small_Array: a fixed-capacity array with a count, and no +;;;; allocation anywhere. + +(defstruct Small [items [$n $t] count i32]) + +;; A generic function over a generic struct binds both of its parameters from +;; the argument, and reads the length back as a value. +(defn append! [s (Ptr (Small $n $t)) x $t] bool + (if (< (.count s) n) + (do (set (at (.items s) (.count s)) x) + (set (.count s) (+ (.count s) 1)) + true) + false)) + +;; One generic over the struct calling another at its own variables. +(defn append-all! [s (Ptr (Small $n $t)) xs [$t]] () + (dotimes [i (length xs)] + (append! s (at xs i)))) + +(defn pop! [s (Ptr (Small $n $t))] (Option $t) + (if (= (.count s) 0) + None + (do (set (.count s) (- (.count s) 1)) + (Some (at (.items s) (.count s)))))) + +(defn capacity [s (Ptr (Small $n $t))] i32 n) + +(defn total [s (Ptr (Small $n $t))] $t {:where (numeric? $t)} + (let [acc (the $t 0)] + (dotimes [i (.count s)] + (set acc (+ acc (at (.items s) i)))) + acc)) + +;; A type parameter alone, built positionally with the type read off the +;; fields, and returned under a variable. +(defstruct Pair [a $t b $t]) + +(defn swapped [p (Pair $t)] (Pair $t) (Pair (.b p) (.a p))) + +;; A copy that names itself through a pointer, and a literal field that +;; takes its width from the one beside it. +(defstruct Node [v $t next (Option (Ptr (Node $t)))]) + +(defn sum-list [n (Ptr (Node i64))] i64 + (loop [at n acc (the i64 0)] + (let [acc (+ acc (.v at))] + (match (.next at) + (Some p) (recur p acc) + None acc)))) + +;; A template naming another at its own parameters. +(defstruct Twice [x (Small $m $u) y (Small $m $u)]) + +;; A copy as a map key, and a named function over one handed where a +;; function value is wanted. +(defn pair-sum [p (Pair i32)] i32 (+ (.a p) (.b p))) +(defn apply-to [f (Fn [(Pair i32)] i32) p (Pair i32)] i32 (f p)) + +;; A length variable straight on an array parameter. +(defn len-of [a [$k $e]] i32 k) + +(defconst cap 3) + +(defn main [] i32 + (let [s (the (Small 4 i32) (zeroed)) + f (the (Small cap f64) (zeroed))] + (append! (addr s) 10) + (append! (addr s) 20) + (append! (addr s) 30) + (println (total (addr s)) (.count s) (capacity (addr s))) + (append! (addr f) 1.5) + (append! (addr f) 2.5) + (append! (addr f) 3.5) + (println (append! (addr f) 4.5) (total (addr f)) (capacity (addr f))) + (println (pop! (addr f)) (pop! (addr f)) (.count f)) + (let [p (Pair 1 2) + q (swapped p) + r (swapped (Pair {.a 1.5 .b 2.5}))] + (println (.a q) (.b q) (.a r) (.b r)) + (println q (Pair 1 2.5))) + (let [c (the (Node i64) {.v 3}) + b (Node 2 (Some (addr c))) + a (Node 1 (Some (addr b)))] + (println (sum-list (addr a)))) + (let [w (the (Twice 2 u8) (zeroed))] + (append! (addr (.y w)) 7) + (println (.count (.x w)) (.count (.y w)) (capacity (addr (.x w))))) + (println (len-of [1 2 3]) (len-of [1.5 2.5])) + (let [v (vec-new (Pair i32))] + (push v (Pair 5 6)) + (println (.b (at v 0))) + (free v)) + (let [t (the (Small 5 i64) (zeroed)) + xs (the [3 i64] [1 2 3])] + (append-all! (addr t) (slice xs)) + (println (total (addr t)) (.count t))) + (let [m (map-new (Pair i32) i32)] + (put m (Pair 1 2) 12) + (put m (Pair 3 4) 34) + (println (get m (Pair 3 4)) (get m (Pair 2 1)) (apply-to pair-sum (Pair 7 8))) + (free m)) + 0)) diff --git a/test/programs/grow-param.flan b/test/programs/grow-param.flan new file mode 100644 index 00000000..4e0186c4 --- /dev/null +++ b/test/programs/grow-param.flan @@ -0,0 +1,35 @@ +;;;; A container parameter is a copy of the caller's header. Growing it grows +;;;; the copy, so the caller's container does not see the push; the function +;;;; is warned at, at the parameter, and the fix it names is the (Ptr ...) +;;;; below, which reaches the caller's own header. A struct passed by value +;;;; is a copy too, with its Vec fields in it, and is warned at the same way. + +(defstruct Bag [items (Vec i32) n i32]) +(defstruct Box [bag Bag]) + +(defn add-copy [v (Vec i32)] () (push v 1) (free v)) +(defn add-ptr [v (Ptr (Vec i32))] () (push (deref v) 2)) +(defn put-ptr [m (Ptr (Map i32 i32))] () (put (deref m) 7 8)) +(defn bag-copy [b Bag] () (push (.items b) 1) (free (.items b))) +(defn bag-ptr [x (Ptr Box)] () (push (.items (.bag x)) 3)) + +(defn main [] i32 + (let [v (vec-new i32) + m (map-new i32 i32)] + (add-copy v) + (println (length v)) ; 0 + (add-ptr (addr v)) + (add-ptr (addr v)) + (println (length v)) ; 2 + (println (at v 1)) ; 2 + (put-ptr (addr m)) + (println (length m)) ; 1 + (free v) + (free m)) + (let [x (Box {.bag (Bag {.items (vec-new i32) .n 0})})] + (bag-copy (.bag x)) + (println (length (.items (.bag x)))) ; 0 + (bag-ptr (addr x)) + (println (at (.items (.bag x)) 0)) ; 3 + (free (.items (.bag x)))) + 0) diff --git a/test/programs/into-owning.flan b/test/programs/into-owning.flan new file mode 100644 index 00000000..48bc4aaf --- /dev/null +++ b/test/programs/into-owning.flan @@ -0,0 +1,22 @@ +;;;; into over elements that own storage. Without a (map f) in the chain the +;;;; elements are pushed as they stand, which copies their headers and shares +;;;; their blocks — so that is refused, and (map clone) is the copy that +;;;; compiles. The outer Vecs are in an arena, as a container of owning +;;;; elements has to be; the inner ones are on the heap, where growing one +;;;; through a shared header would free the block the other still points at. + +(defn main [] i32 + (let [a (arena-new 65536) + v (vec-new (Vec i32) a)] + (push v (vec-new i32)) + (push (at v 0) 1) + (let [w (into v (vec-new (Vec i32) a) (map clone))] + (dotimes [i 100] (push (at w 0) i)) + (println (at (at v 0) 0)) ; 1 + (println (length (at v 0))) ; 1 + (println (length (at w 0))) ; 101 + (println (at (at w 0) 100)) ; 99 + (free (at w 0))) + (free (at v 0)) + (arena-destroy a) + 0)) diff --git a/test/programs/prelude-names.flan b/test/programs/prelude-names.flan new file mode 100644 index 00000000..a5fb7267 --- /dev/null +++ b/test/programs/prelude-names.flan @@ -0,0 +1,22 @@ +;;;; A program's names do not change what the prelude means. The prelude's +;;;; generics write their type variable bare, (vec-new t), and name +;;;; parameters t, k and v; a global or a type the program declares under one +;;;; of those names is the program's, and the prelude's own reading stands. + +(defonce t [4 i32]) +(defstruct k [x i32]) +(defenum v [lo hi]) + +(defn even? [x i32] bool (= (% x 2) 0)) + +(defn main [] i32 + (set (at t 0) 7) + (let [xs [1 2 3 4 5 6] + evens (filter (slice xs) even?)] + (println (length evens)) ; 3 + (println (at evens 2)) ; 6 + (free evens)) + (println (at t 0)) ; 7 + (println (.x (k {.x 5}))) ; 5 + (println (i32 (v 1))) ; 1 + 0) diff --git a/test/programs/shadow-prelude-global.flan b/test/programs/shadow-prelude-global.flan new file mode 100644 index 00000000..9cd578b7 --- /dev/null +++ b/test/programs/shadow-prelude-global.flan @@ -0,0 +1,14 @@ +;;;; A program's global named as a prelude function takes the name over for +;;;; its own file, as a program's function does, and the prelude's own calls +;;;; keep the prelude's: sort still swaps with the prelude's swap. +(defonce swap i32 3) +(defonce clamp i32 4) +(defconst reverse i32 5) + +(defn main [] i32 + (println (+ swap clamp reverse)) ; 12 + (let [xs [3 1 2]] + (sort (slice xs)) + (println (at xs 0)) ; 1 + (println (at xs 2))) ; 3 + 0) diff --git a/test/programs/shadow-prelude.flan b/test/programs/shadow-prelude.flan index a9d628ae..23cf3661 100644 --- a/test/programs/shadow-prelude.flan +++ b/test/programs/shadow-prelude.flan @@ -1,13 +1,23 @@ ;;;; A program's function named as a prelude function takes the name over for ;;;; the calls in its own file, and the prelude's own calls keep the prelude's: ;;;; ceil-f32 is written over the prelude's floor-f32, and still answers 3. +;;;; A prelude macro is taken over the same way: clamp and update below are +;;;; the program's functions, and format-f64, which the prelude writes with +;;;; its own clamp, still clamps its precision to 9. (defn abs-f32 [v f32] f32 (if (< v 0.0) (- v) (+ v (f32 100.0)))) (defn floor-f32 [x f32] f32 (f32 999.0)) (defn abs [x i32] i32 (* x 10)) +(defn clamp [x i32 lo i32 hi i32] i32 (+ x lo hi)) +(defn update [x i32] i32 (* x 7)) (defn main [] i32 (println (abs-f32 (f32 -2.5))) (println (abs-f32 (f32 2.5))) (println (floor-f32 (f32 2.3))) (println (ceil-f32 (f32 2.3))) (println (abs -3)) + (println (clamp 1 2 3)) + (println (update 6)) + (let [s (format-f64 0.5 40)] + (println (length s)) + (free s)) 0) diff --git a/test/programs/update-place.flan b/test/programs/update-place.flan new file mode 100644 index 00000000..8da35858 --- /dev/null +++ b/test/programs/update-place.flan @@ -0,0 +1,55 @@ +;;;; update, ++ and -- evaluate every subexpression of their place once, as +;;;; C's compound assignment does. `calls` counts the index function: one call +;;;; per form, and the read and the write land on the same element. + +(defonce calls i32 0) + +(defn next-index [] i32 + (set calls (+ calls 1)) + (- calls 1)) + +(defstruct Body [velocity i32 hits [3 i32]]) + +(defn add [x i32 y i32] i32 (+ x y)) + +(defclass counter [n i32]) + +(defn which-slot [] dyn + (set calls (+ calls 1)) + :n) + +(defn main [] i32 + (let [xs [10 20 30] + v (vec-new i32) + g (Body {.velocity 5})] + (push v 1) (push v 2) (push v 3) + ;; next-index answers 0, then 1, then 2. + (++ (at xs (next-index))) + (-- (at v (next-index))) + (update (at xs (next-index)) * 3) + (println calls) ; 3 + (println (at xs 0) (at xs 1) (at xs 2)) ; 11 20 90 + (println (at v 0) (at v 1) (at v 2)) ; 1 1 3 + ;; A field, with a macro as the function, and with arguments after it. + (update (.velocity g) inc) + (update (.velocity g) add 10) + (println (.velocity g)) ; 16 + ;; A path through a field into an element: the struct is written in place, + ;; not in a copy. + (set calls 0) + (update (at (.hits g) (next-index)) + 7) + (++ (at (.hits g) (next-index))) + (println calls) ; 2 + (println (at (.hits g) 0) (at (.hits g) 1)) ; 7 1 + ;; Through a pointer. + (let [p (addr (.velocity g))] + (update (deref p) * 2) + (println (.velocity g))) ; 32 + (free v)) + ;; A class slot, with the key computed once. + (let [c (counter 4)] + (set calls 0) + (++ (get c (which-slot))) + (update (get c (which-slot)) * 10) + (println calls (get c :n))) ; 2 50 + 0) diff --git a/test/test_acceptance.ml b/test/test_acceptance.ml index 19a2ae4a..29f9a0b3 100644 --- a/test/test_acceptance.ml +++ b/test/test_acceptance.ml @@ -432,6 +432,13 @@ let () = match_enum_out; outputs ~dev:true "match over an enum, dev" "programs/match-enum.flan" match_enum_out; + (* update, ++ and -- evaluate their place's subexpressions once: the + counts are the number of calls an index or a key function got. *) + let update_out = "3\n11 20 90\n1 1 3\n16\n2\n7 1\n32\n2 50\n" in + outputs "update evaluates its place once" "programs/update-place.flan" + update_out; + outputs ~x86:true "update evaluates its place once, --x86" + "programs/update-place.flan" update_out; (* The count is [length] so that [len] is left to programs, and this is the claim that it really is one: a local holding a count, a parameter, and a defn the program calls by its bare name, all of @@ -581,10 +588,15 @@ let () = "programs/array-mixed.flan" mixed_out; (* A program's function named as a prelude function takes the name over for its own file; the prelude's own calls keep the prelude's. *) - let sp_out = "2.5\n102.5\n999\n3\n-30\n" in + let sp_out = "2.5\n102.5\n999\n3\n-30\n6\n42\n11\n" in outputs "a prelude function shadowed" "programs/shadow-prelude.flan" sp_out; outputs ~x86:true "a prelude function shadowed, x86" "programs/shadow-prelude.flan" sp_out; + (* And by a program's global, the same way. *) + outputs "a prelude function shadowed by a global" + "programs/shadow-prelude-global.flan" "12\n1\n3\n"; + outputs ~x86:true "a prelude function shadowed by a global, x86" + "programs/shadow-prelude-global.flan" "12\n1\n3\n"; (* (max-value T) and (min-value T), concrete and inside a generic. *) let maxof_out = "255\n0\n127\n-128\n2147483647\n-9223372036854775808\n\ @@ -613,6 +625,20 @@ let () = source transformed in two orders, which have to differ. *) outputs "into" "programs/into.flan" "7 8 9 \n2 4 6 8 10 12 \n4 8 12 \n21\n6 2 4 \n3 1 2 \n3 4 \n2 4 \n1\n"; + (* The fix into's refusal names for owning elements, (map clone): the + copy's inner Vec grows on the heap and the source's is untouched. *) + (* Program names that spell the prelude's own leave the prelude alone. *) + outputs "a program's names and the prelude's" "programs/prelude-names.flan" + "3\n6\n7\n5\n1\n"; + outputs ~x86:true "a program's names and the prelude's, --x86" + "programs/prelude-names.flan" "3\n6\n7\n5\n1\n"; + (* A grown container parameter reaches the caller only through a Ptr. *) + outputs "a grown parameter" "programs/grow-param.flan" "0\n2\n2\n1\n0\n3\n"; + outputs ~x86:true "a grown parameter, --x86" "programs/grow-param.flan" + "0\n2\n2\n1\n0\n3\n"; + outputs "into with (map clone)" "programs/into-owning.flan" "1\n1\n101\n99\n"; + outputs ~x86:true "into with (map clone), --x86" "programs/into-owning.flan" + "1\n1\n101\n99\n"; (* The prelude's slice algorithms. Every assertion here is over an input a wrong implementation fails: unsorted with duplicates, negatives and an odd length; a reverse-sorted slice; and a sort of a subslice whose @@ -881,7 +907,7 @@ let () = *by* build shape (trap at -O0, silent no-op at -O2) and the copy must not. *) let bytes_copy_out = - "ZNSERTIONSORT\nINSERTIONSORT\nHi\n3\n99\narenA\n" + "ZNSERTIONSORT\nINSERTIONSORT\nHi\n3\n99\narenA\n3\n" in outputs "bytes copies, bytes-view aliases" "programs/bytes-copy.flan" bytes_copy_out; @@ -889,6 +915,37 @@ let () = "programs/bytes-copy.flan" bytes_copy_out; outputs ~x86:true "bytes copies, bytes-view aliases, --x86" "programs/bytes-copy.flan" bytes_copy_out; + (* (free s) on a slice: through the context allocator and through a named + one, every backend; and in a dev build, the registry's three refusals — + another allocator's block, a block freed twice, a view no allocator + handed out. *) + let fs = "programs/free-slice.flan" in + outputs "free on a slice" fs "heap arena 2.5\ndone\n"; + outputs ~opt:"-O0" "free on a slice, -O0" fs "heap arena 2.5\ndone\n"; + outputs ~x86:true "free on a slice, --x86" fs "heap arena 2.5\ndone\n"; + List.iter + (fun (x86, tag) -> + let exe = compile ~x86 ~dev:true fs in + List.iter + (fun (arg, line, want) -> + let code, text = run exe (Some arg) in + if code <> 134 + || not (contains text + (Printf.sprintf "programs/free-slice.flan:%d:" line)) + || not (contains text want) || contains text "done" + then begin + incr failures; + Printf.printf + "FAIL a dev build refuses a bad free of a slice, argument \ + %s%s\n got: %S (exit %d)\n" arg tag text code + end) + [ ("1", 13, "came from another allocator"); + ("2", 14, "was already freed"); + ("3", 17, "not a block an allocator handed out"); + ("4", 21, "views a Vec's or a Map's storage"); + ("5", 24, "released all at once by (free-temp)") ]; + (try Sys.remove exe with Sys_error _ -> ())) + [ (false, ", dev"); (true, ", dev --x86") ]; (* The other half of the same ruling: a store through a bytes-view is refused before anything is built, because bytes-view answers a [const u8]. It used to compile and trap at -O0 on both backends, and be @@ -1916,7 +1973,7 @@ let () = let dyn_if_truthy_out = "falsey\nfalsey\ntruthy\ntruthy\ntruthy\ntruthy\ntruthy\ntruthy\ntruthy\n\ truthy\ntruthy\ntruthy\nwhen 0 ran\nwhen empty-string ran\nb\nb\n\ - :kw\nfalse\nnil\n\n0\nfalse\nx\n5\n\ + :kw\nfalse\nnil\n\n0\nfalse\nx\n5\ns\nnil\nnil\ny\ntrue\n\ nil\n\nnil\n0\ntrue\nfalse\n\ nil\nand-reached\n2\n7\nor-reached\n1\n\ and-decider\nnil\nor-decider\n9\n\ @@ -3466,6 +3523,19 @@ let () = outputs "generics" "programs/generics.flan" generics_out; outputs ~opt:"-O0" "generics, -O0" "programs/generics.flan" generics_out; + (* Generic structs — see the program's header. The third line is two pops + printed in one call, which is also the pin for a printed call being + evaluated once: the walk reads an option's tag and then its payload, + and each read used to make the call again. *) + let generic_struct_out = + "60 3 4\nfalse 7.5 3\n(some 3.5) (some 2.5) 1\n2 1 2.5 1.5\n\ + (Pair i32 {.a 2 .b 1}) (Pair f64 {.a 1 .b 2.5})\n6\n\ + 0 1 2\n3 2\n6\n6 3\n(some 34) none 15\n" + in + outputs "generic structs" "programs/generic-struct.flan" generic_struct_out; + outputs ~x86:true "generic structs, --x86" "programs/generic-struct.flan" + generic_struct_out; + (* integer?, end to end — see the program's own header. The first eight lines are the collapsed abs at six widths and both signed minimums (which answer themselves; the negation wraps). The [0 0] after them is @@ -3608,7 +3678,7 @@ let () = chain of instantiations and not a depth it gave up at. *) refuses "an unconstrained operator in a generic body" "programs/generic-reject.flan" - "nothing declares t numeric?"; + "nothing declares $t numeric?"; refuses "an unconstrained operator names the way out" "programs/generic-reject.flan" "{:where (numeric? $t)}"; refuses "a runaway instantiation" "programs/generic-runaway.flan" @@ -4166,6 +4236,11 @@ level "1" lo\nmid\nhi\nother\n" in outputs "enum conversion" "programs/enum-convert.flan" enum_conv_out; + (* The generic enum-to-number conversion enum? licenses. *) + outputs "a generic enum conversion" "programs/enum-generic.flan" + "2\n20\ntrue\ntrue\n20\n"; + outputs ~x86:true "a generic enum conversion, --x86" + "programs/enum-generic.flan" "2\n20\ntrue\ntrue\n20\n"; outputs ~opt:"-O0" "enum conversion, -O0" "programs/enum-convert.flan" enum_conv_out; @@ -4217,6 +4292,36 @@ level "1" end in let v2 = "(defstruct Vector2 [x f32 y f32])\n" in + + (* A generic struct's copy crosses behind a pointer, as a typedef of its + own with the arguments written in, and one held by value inside a + struct is defined before that struct. clang reads the text, so the + typedef is C and not only a spelling. *) + let gsrc = + "(defstruct G [x $t count i32])\n\ + (defstruct O [v i32 inner (G u8)])\n\ + (declare-c c-g [s (Ptr (G u8))] i32 \"c_g\")\n\ + (declare-c c-o [o (Ptr O)] i32 \"c_o\")\n" + in + shim_case "declare-c: a generic struct's copy crosses behind a pointer" gsrc + [ "/* (G u8) */\n uint8_t x;\n int32_t count;\n"; "inner;\n" ]; + (match shim_of gsrc with + | c -> + let file = Filename.temp_file "flan-shim-generic" ".c" in + let oc = open_out file in + output_string oc c; + close_out oc; + if Sys.command (Printf.sprintf "clang -fsyntax-only %s" (Filename.quote file)) <> 0 + then begin + incr failures; + print_endline "FAIL declare-c: a generic struct's copy is C clang accepts" + end; + Sys.remove file + | exception Loc.Error _ -> ()); + shim_refuses "declare-c: a generic struct's copy by value" + "(defstruct G [x $t])\n(declare-c c-v [s (G u8)] i32 \"c_v\")" + "crosses to C behind a pointer only"; + let img = "(defstruct Image [data (Ptr u8) width i32 height i32])\n" in @@ -4660,6 +4765,35 @@ level "1" outputs ~dev:true "the two function types, dev" "programs/fn-cfn.flan" fn_ptr_out; + (* A CFn in a struct field, a fixed array and a global, each zeroed until + stored into. A call through an empty one signals NullCall, before its + arguments run; answered, the program carries on, and unanswered it dies + naming the site and the type — on both backends. *) + let cfn_table_out = + "14\nempty\n-7\nempty\nempty\n4\n3\n3\n(CFn [i32] i32)\n-9\n" + in + outputs "a CFn table" "programs/fn-cfn-table.flan" cfn_table_out; + outputs ~x86:true "a CFn table, --x86" "programs/fn-cfn-table.flan" + cfn_table_out; + outputs ~dev:true "a CFn table, dev" "programs/fn-cfn-table.flan" + cfn_table_out; + List.iter + (fun x86 -> + let exe = compile ~x86 "programs/fn-cfn-table.flan" in + let code, text = run exe (Some "1") in + if code <> 134 + || not (contains text "programs/fn-cfn-table.flan:") + || not (contains text "this call is through a (CFn [i32] i32) \ + that holds no function") + then begin + incr failures; + Printf.printf "FAIL an unanswered empty CFn call dies%s\n \ + got: %S (exit %d)\n" + (if x86 then ", --x86" else "") text code + end; + (try Sys.remove exe with Sys_error _ -> ())) + [ false; true ]; + (* Two signatures that flatten to one string under [mangle_ty], which is how the thunk memo used to be keyed. Keyed on the name, the second widening reuses the first's thunk at the wrong arity — a miscompile @@ -4694,10 +4828,10 @@ level "1" the easier of the two to leave open. *) refuses "a nested function type does not widen" "programs/fn-generic-nested.flan" - "hof expects (Fn [(Fn [t] t)] i32) here"; + "hof expects (Fn [(Fn [$t] $t)] i32) here"; refuses "and neither does one in return position" "programs/fn-generic-nested-return.flan" - "call-twice expects (Fn [] (Fn [] t)) here"; + "call-twice expects (Fn [] (Fn [] $t)) here"; outputs ~dev:true "an fn capturing by value, dev" "programs/fn-capture.flan" fn_capture_out; @@ -4915,6 +5049,17 @@ level "1" "(defn main [] i32 (++) 0)" "++-takes-one-place"; macro_arity "-- with two arguments" "(defn main [] i32 (let [a 1 b 2] (-- a b)) 0)" "---takes-one-place"; + macro_arity "update with no function" + "(defn main [] i32 (let [a 1] (update a)) 0)" + "update-takes-a-place-and-a-function"; + (* A place update takes is a place set takes, and is refused the same way. *) + macro_arity "update of something that is not a place" + "(defn main [] i32 (update 5 inc) 0)" "5 is not assignable"; + macro_arity "update of a parameter" + "(defn f [a i32] () (update a inc))" "a is a parameter"; + macro_arity "update whose function answers the wrong type" + "(defn yes [x i32] bool true)\n(defn f [] () (let [a 1] (update a yes)))" + "expected i32"; (* unless keeps a guard, and it is now the narrower one: a body may be missing, a test may not. *) macro_arity "unless with no test at all" @@ -7109,6 +7254,9 @@ level "1" (let code, text = cli "check programs/shadow-prelude.flan" in if code <> 0 || contains text "prelude~" || not (contains text "defn floor-f32") + (* A macro taken over is warned about as a function is. *) + || not (contains text "clamp shadows the prelude's clamp") + || not (contains text "update shadows the prelude's update") then begin incr failures; Printf.printf diff --git a/test/test_agent.ml b/test/test_agent.ml index def7521c..93ba88e0 100644 --- a/test/test_agent.ml +++ b/test/test_agent.ml @@ -61,6 +61,14 @@ let send path line = Unix.close s; Buffer.contents b +(* The pair the daemon sets: the path, and the pid it is meant for. This test + binary is the parent of every program it starts, which is the + --two-process shape. *) +let daemon_env path = + let me = string_of_int (Unix.getpid ()) in + [| "FLAN_AGENT_SOCKET=" ^ path; "FLAN_AGENT_OWNER=" ^ me; + "FLAN_DEV_PARENT=" ^ me |] + let () = match Sys.command "command -v clang > /dev/null 2>&1 && command -v llc > /dev/null 2>&1" with | 0 -> @@ -298,7 +306,7 @@ let () = let bad = tmp "bad.out" in let bfd' = ofd bad in let benv = - Array.append aenv [| "FLAN_AGENT_SOCKET=/nonexistent-dir/agent.sock" |] + Array.append aenv (daemon_env "/nonexistent-dir/agent.sock") in let bpid' = Unix.create_process_env aexe [| aexe |] benv Unix.stdin bfd' bfd' in Unix.close bfd'; @@ -325,6 +333,79 @@ let () = "cannot listen\n" end; + (* ── The variable inherited by a process the daemon did not start ── *) + + (* A shell opened from inside a [flan dev] program carries its + FLAN_AGENT_SOCKET, and so does anything run from that shell. Binding + unlinks the path first, so honouring it there would take the session's + socket from its program. FLAN_AGENT_OWNER names the process the daemon + launched; pid 1 is neither this program nor its parent, so the variable + is not this program's, and it picks and announces a path of its own as + if nothing were set. The file standing in for the session's socket has + to still be the same file afterwards. *) + let inherited ~shape ~owner = + let stolen = tmp "stolen.sock" and serr = tmp "stolen.err" in + Out_channel.with_open_bin stolen (fun oc -> + output_string oc "the session's"); + let senv = + Array.append aenv + [| "FLAN_AGENT_SOCKET=" ^ stolen; "FLAN_AGENT_OWNER=" ^ owner |] + in + let s1 = ofd (tmp "stolen.out") and s2 = ofd serr in + let spid = Unix.create_process_env aexe [| aexe |] senv Unix.stdin s1 s2 in + Unix.close s1; + Unix.close s2; + let prefix = "flan agent: listening on " in + let sannounced () = + let text = In_channel.with_open_bin serr In_channel.input_all in + List.find_map + (fun l -> + if String.length l > String.length prefix + && String.sub l 0 (String.length prefix) = prefix + then Some (String.sub l (String.length prefix) + (String.length l - String.length prefix)) + else None) + (String.split_on_char '\n' text) + in + (match + if await (fun () -> sannounced () <> None) then sannounced () else None + with + | None -> + fail "%s: a program with someone else's FLAN_AGENT_SOCKET announced no \ + socket of its own" shape; + (try Unix.kill spid Sys.sigkill with Unix.Unix_error _ -> ()) + | Some p -> + if p = stolen then fail "%s: the inherited path was bound: %S" shape p; + if not (await (fun () -> Sys.file_exists p)) then + fail "%s: nothing was bound at the announced %S" shape p + else ignore (send p aso); + let reaped = + await ~ms:5000 (fun () -> + match Unix.waitpid [ Unix.WNOHANG ] spid with + | 0, _ -> false + | _ -> true) + in + if not reaped then begin + (try Unix.kill spid Sys.sigkill with Unix.Unix_error _ -> ()); + fail "%s: the program with an inherited variable never finished" shape + end); + (match In_channel.with_open_bin stolen In_channel.input_all with + | "the session's" -> () + | _ -> fail "%s: the inherited FLAN_AGENT_SOCKET's file was replaced" shape + | exception Sys_error _ -> + fail "%s: the inherited FLAN_AGENT_SOCKET's file was removed" shape); + List.iter (fun f -> try Sys.remove f with Sys_error _ -> ()) + [ stolen; serr; tmp "stolen.out" ] + in + (* Nobody's pid. *) + inherited ~shape:"an owner that is not this process" ~owner:"1"; + (* A merged build's owner is the program itself, so a process the program + starts has the owner as its parent; with no FLAN_DEV_PARENT naming it, + that is not the --two-process shape and the socket is not its. Here the + test binary stands in for the program. *) + inherited ~shape:"a child of a merged program" + ~owner:(string_of_int (Unix.getpid ())); + List.iter (fun f -> try Sys.remove f with Sys_error _ -> ()) [ aexe; aso; aout; aerr; bad ]; @@ -359,7 +440,7 @@ let () = let nc = Session.eval nt "(defn tick [] i64 1000)" in ignore (Build.shared ~opts:dev ~ir:nc.Session.ir ~out:nso ()); let nenv = - Array.append (Unix.environment ()) [| "FLAN_AGENT_SOCKET=" ^ nsock |] + Array.append (Unix.environment ()) (daemon_env nsock) in let nfd = Unix.openfile nout [ Unix.O_WRONLY; Unix.O_CREAT; Unix.O_TRUNC ] 0o600 @@ -412,7 +493,7 @@ let () = bt.Session.host ~out:bexe); let bfd = Unix.openfile bout [ Unix.O_WRONLY; Unix.O_CREAT; Unix.O_TRUNC ] 0o600 in let env = - Array.append (Unix.environment ()) [| "FLAN_AGENT_SOCKET=" ^ bsock |] + Array.append (Unix.environment ()) (daemon_env bsock) in let bpid = Unix.create_process_env bexe [| bexe |] env Unix.stdin bfd bfd @@ -753,7 +834,7 @@ let () = lt.Session.host ~out:lexe); let lfd = Unix.openfile lout [ Unix.O_WRONLY; Unix.O_CREAT; Unix.O_TRUNC ] 0o600 in let lenv = - Array.append (Unix.environment ()) [| "FLAN_AGENT_SOCKET=" ^ lsock |] + Array.append (Unix.environment ()) (daemon_env lsock) in let lpid = Unix.create_process_env lexe [| lexe |] lenv Unix.stdin lfd lfd in Unix.close lfd; diff --git a/test/test_dev.ml b/test/test_dev.ml index fa86db9c..6789224b 100644 --- a/test/test_dev.ml +++ b/test/test_dev.ml @@ -127,6 +127,166 @@ let status r = let contains_sub = Test_support.contains +(* The stepper, against a running program whose [step] is dev-pause.flan's + and dev-repl.flan's: sent with [:step t], a call stops before each form of + its body — the (set ...), then after [next] the [ticks] it answers. + [continue] runs the rest of the call and the next call steps again, and a + plain evaluation takes it out. Run in a daemon of each backend that another + block already started, so it costs no build of its own. *) +let stepper_checks ~what ask = + let stopped r = + match Wire.field r "stopped" with + | Some { Form.v = Form.Sym "t"; _ } -> true + | _ -> false + in + let body = "(defn step [] i64 (set ticks (+ ticks 1)) ticks)" in + let col sub = + let n = String.length sub in + let rec find i = + if String.equal (String.sub body i n) sub then i + 1 else find (i + 1) + in + find 0 + in + (* Where the stepped frame is: the frame of [step], whose location is + the step point's, which is the form about to run. *) + let at () = + match Wire.field (ask "(:op \"backtrace\")") "frames" with + | Some { Form.v = Form.List l; _ } -> + List.find_map + (fun (f : Form.t) -> + match f.Form.v with + | Form.List ({ Form.v = Form.Str "step"; _ } + :: { Form.v = Form.Str loc; _ } :: _) -> Some loc + | _ -> None) + l + | _ -> None + in + let stops_at sub = + let want = Printf.sprintf ":1:%d" (col sub) in + await (fun () -> + stopped (ask "(:op \"describe\")") + && (match at () with Some l -> contains_sub l want | None -> false)) + in + let r = + ask + (Printf.sprintf "(:op \"eval\" :code %s :file \"/tmp/step.flan\" :step t)" + (Wire.quote body)) + in + if status r <> "ok" then + fail "%sinstrumenting for the stepper: %s" what + (Option.value ~default:"" (Wire.string_field r "message")) + else begin + if Wire.field r "step" = None then + fail "%san instrumented defn did not echo :step" what; + if not (stops_at "(set ticks") then + fail "%sthe stepper did not stop before the first form (at %s)" what + (Option.value ~default:"" (at ())) + else begin + (match Wire.string_field (ask "(:op \"describe\")") "condition" with + | Some "StepPoint" -> () + | c -> fail "%sa step stopped on %s" what (Option.value ~default:"" c)); + (* The stepper's own local is not one of the frame's. *) + let fr = ask "(:op \"locals\" :frame 1)" in + (match Wire.string_field fr "frame" with + | Some "step" -> + (match Wire.field fr "locals" with + | Some { Form.v = Form.List []; _ } | None -> () + | _ -> fail "%sthe stepper's flag is listed as a local" what) + | f -> fail "%sframe 1 at a step is %s" what (Option.value ~default:"" f)); + let r = ask "(:op \"restart\" :name \"next\")" in + if status r <> "ok" then + fail "%snext at a step: %s" what + (Option.value ~default:"" (Wire.string_field r "message")); + if not (stops_at "ticks)") then + fail "%snext did not stop before the second form (at %s)" what + (Option.value ~default:"" (at ())); + let r = ask "(:op \"restart\" :name \"continue\")" in + if status r <> "ok" then + fail "%scontinue at a step: %s" what + (Option.value ~default:"" (Wire.string_field r "message")); + (* The next call, 5ms on, steps again from the top. *) + if not (stops_at "(set ticks") then + fail "%sthe next call did not step again" what; + let r = + ask + (Printf.sprintf "(:op \"eval\" :code %s :file \"/tmp/step.flan\")" + (Wire.quote body)) + in + if status r <> "ok" then + fail "%sinstalling the plain defn: %s" what + (Option.value ~default:"" (Wire.string_field r "message")); + ignore (ask "(:op \"restart\" :name \"continue\")"); + if not (await (fun () -> not (stopped (ask "(:op \"describe\")")))) then + fail "%sthe program did not resume from the last step" what; + let deadline = Unix.gettimeofday () +. 0.5 in + let rec run_on () = + if Unix.gettimeofday () > deadline then () + else if stopped (ask "(:op \"describe\")") then + fail "%sthe plain defn still steps" what + else begin + ignore (Unix.select [] [] [] 0.01); + run_on () + end + in + run_on () + end + end + +(* Eval-in-frame against dev-locals.flan's [look], stopped at its (error ...): + the expression sees that frame's locals, the inner of two [label]s wins, a + [set] writes the frame's own storage, and a local not bound yet is refused + by name. [ask] sends one request. Run under each backend. *) +let eval_in_frame_checks ~backend ask = + let value code = + let r = + ask (Printf.sprintf "(:op \"eval-expr\" :frame 0 :code %S)" code) + in + if status r = "ok" then Ok (Option.value ~default:"" (Wire.string_field r "value")) + else Error (Option.value ~default:(status r) (Wire.string_field r "message")) + in + let expect code want = + match value code with + | Ok v when v = want -> () + | Ok v -> fail "%s eval-in-frame %s answered %S, wanted %S" backend code v want + | Error m -> fail "%s eval-in-frame %s: %s" backend code m + in + expect "(+ n 1)" "4"; + expect "(.y p)" "2.5"; + expect "label" "\"inner\""; + expect "(do (set flag false) flag)" "false"; + (match + Wire.field (ask "(:op \"locals\" :frame 0)") "locals" + with + | Some { Form.v = Form.List rows; _ } -> + if not + (List.exists + (fun (e : Form.t) -> + match e.Form.v with + | Form.List ({ Form.v = Form.Str "flag"; _ } :: _ + :: { Form.v = Form.Str "false"; _ } :: _) -> true + | _ -> false) + rows) + then fail "%s eval-in-frame: a set did not reach the frame" backend + | _ -> fail "%s eval-in-frame: no locals after the set" backend); + expect "(do (set flag true) flag)" "true"; + (match value "(+ after 1)" with + | Error m when contains_sub m "after is not bound yet" -> () + | Error m -> fail "%s eval-in-frame of an unbound local said %s" backend m + | Ok v -> fail "%s eval-in-frame read an unbound local as %s" backend v); + (match value "(+ n \"x\")" with + | Error _ -> () + | Ok v -> fail "%s eval-in-frame accepted a type error: %s" backend v); + (* Addressed to a stop that is over: the agent drops it, and the reply says + why at once rather than timing out. *) + let t0 = Unix.gettimeofday () in + let r = ask "(:op \"eval-expr\" :frame 0 :at-stop 999999 :code \"n\")" in + let m = Option.value ~default:"" (Wire.string_field r "message") in + if status r = "ok" then fail "%s eval-in-frame ran at a stop that is over" backend + else if not (contains_sub m "resumed" || contains_sub m "stopped again") then + fail "%s eval-in-frame at a stop that is over said %s" backend m + else if Unix.gettimeofday () -. t0 > 4.0 then + fail "%s eval-in-frame at a stop that is over waited out the clock" backend + (* ── The one verb whose reply races the process it ends ─────────────── *) (* [abort] is answered twice over, and the two answers are not ordered. On the @@ -194,7 +354,21 @@ let () = explain and is quoted as it stands. *) let other = Dev.refusal ~parked:true "err flan.abi.x86: the module is x86" in if not (contains_sub other "flan.abi.x86") then - fail "a parked program's other refusals were rewritten too: %S" other + fail "a parked program's other refusals were rewritten too: %S" other; + (* The agent is always this compiler's, never the copy a program vendors: + an old copy answers every frame at its function's own line. *) + let dir = tmp "agent-dir" in + (try Unix.mkdir dir 0o700 with Unix.Unix_error _ -> ()); + let csrcs, _ = + Dev.with_agent ~dir [ "/far/vendor/agent/flan_agent.c"; "/far/x.c" ] [] + in + let own = Filename.concat dir "flan_agent.c" in + if csrcs <> [ "/far/x.c"; own ] then + fail "a vendored agent was linked in place of the compiler's: %s" + (String.concat " " csrcs) + else if In_channel.with_open_bin own In_channel.input_all + <> Runtime_src.agent_source then + fail "the agent linked is not the compiler's own" (* A daemon's death is reported by the signal's name. [WSIGNALED] carries OCaml's own numbering, in which SIGTERM is -11, and a SIGTERM printed as @@ -628,6 +802,28 @@ let () = | Some { Form.v = Form.Sym "t"; _ } -> () | _ -> fail "an expression against the park reported the program live"); + (* A generic struct's copy prints the way its type is written, with the + arguments after the template's name, and [layout] answers to that + spelling. *) + let r = + request c + "(:op \"eval\" :code \"(defstruct GPair [a $t b $t])\" :file \"/tmp/buf.flan\")" + in + if status r <> "ok" then + fail "a generic struct at the daemon: %s" + (Option.value ~default:(status r) (Wire.string_field r "message")); + let r = + request c + "(:op \"eval-expr\" :code \"(GPair 1 2)\" :file \"/tmp/buf.flan\")" + in + if Wire.string_field r "value" <> Some "(GPair i32 {.a 1 .b 2})" then + fail "a generic struct's copy printed as %s" + (Option.value ~default:(status r) (Wire.string_field r "value")); + let r = request c "(:op \"layout\" :type \"GPair i32\")" in + if Wire.string_field r "type" <> Some "(GPair i32)" then + fail "layout of a copy by its printed head: %s" + (Option.value ~default:(status r) (Wire.string_field r "message")); + (* And the half that needs the process rather than only the compiler. [extra] is a global this session introduced and the first run left at 105 — the third reload's [step] does not touch it — so this is the @@ -2202,6 +2398,88 @@ let () = pointer: the bytes-view write that first crashed no longer compiles. *) trap_park ~refault:true "segfault" "dev-segv.flan" "SegFault" []; + (* ── A break over a call through a null CFn ───────────────────────── + + NullCall is a condition, signalled as a bad index is: nothing handles + it in dev-break-nullcall.flan, so the program parks with NullCall + named, the program's own continue on offer and takeable, and taking it + resumes — the transcript's 1 is continue's clause having run. On both + backends, since the null test before the call is emitted by each. *) + let null_park backend = + let nsock = tmp ("nullcall" ^ backend ^ ".sock") + and nout = tmp ("nullcall" ^ backend ^ ".out") in + (try Sys.remove nsock with Sys_error _ -> ()); + let nfd = + Unix.openfile nout [ Unix.O_WRONLY; Unix.O_CREAT; Unix.O_TRUNC ] 0o600 + in + let npid = + Unix.create_process flan + [| flan; "dev"; "programs/dev-break-nullcall.flan"; "-s"; nsock; backend |] + Unix.stdin nfd Unix.stderr + in + Unix.close nfd; + if not (listening ~pid:npid nsock) then begin + fail "the null-call daemon (%s) %s" backend !listen_why; + (try Unix.kill npid Sys.sigkill with Unix.Unix_error _ -> ()) + end + else begin + let out = Buffer.create 64 in + let c = connect nsock in + let ask sexp = + let r = Wire.parse (Wire.send c sexp; Wire.recv c) in + (match Wire.string_field r "output" with + | Some t -> Buffer.add_string out t + | None -> ()); + r + in + let stopped r = + match Wire.field r "stopped" with + | Some { Form.v = Form.Sym "t"; _ } -> true + | _ -> false + in + let last = ref (Wire.parse "()") in + if not (await (fun () -> last := ask "(:op \"describe\")"; stopped !last)) + then fail "a null CFn call never stopped the program (%s)" backend + else begin + (match Wire.string_field !last "condition" with + | Some "NullCall" -> () + | c -> + fail "a null CFn call is reported as %S (%s)" + (Option.value ~default:"" c) backend); + let r = ask "(:op \"break\")" in + (match Wire.field r "restarts" with + | Some { Form.v = Form.List l; _ } + when List.exists + (fun (n : Form.t) -> n.Form.v = Form.Str "continue") l -> () + | _ -> fail "a null CFn call offers no continue (%s)" backend); + let r = ask "(:op \"restart\" :name \"continue\")" in + if status r <> "ok" then + fail "continuing past a null CFn call (%s): %s" backend + (Option.value ~default:"" (Wire.string_field r "message")); + if not + (await (fun () -> + ignore (ask "(:op \"describe\")"); + List.mem "1" + (String.split_on_char '\n' (Buffer.contents out)))) + then fail "the program never resumed past a null CFn call (%s)" backend + end; + ignore (ask "(:op \"close\")"); + Unix.close c; + if not + (await ~ms:5000 (fun () -> + match Unix.waitpid [ Unix.WNOHANG ] npid with + | 0, _ -> false + | _ -> true + | exception Unix.Unix_error _ -> true)) + then begin + (try Unix.kill npid Sys.sigkill with Unix.Unix_error _ -> ()); + (try ignore (Unix.waitpid [] npid) with Unix.Unix_error _ -> ()) + end + end + in + null_park "--llvm"; + null_park "--x86"; + (* ── The locals of a stopped frame ─────────────────────────────── *) (* A third daemon, over a program that stops with something worth looking @@ -2324,6 +2602,7 @@ let () = (String.concat ", " (List.map (fun (n, w, _) -> n ^ ": " ^ w) (pairs r "refused"))) end; + eval_in_frame_checks ~backend:"llvm" ask; (* A frame whose every slot the compiler invented is not an error and is not an empty answer either: it says which it is. *) let r = ask "(:op \"locals\" :frame 1)" in @@ -2556,6 +2835,21 @@ let () = want "box" "(some)" "Point" "(Point {.x 4.5 .y 5.5})"; want "box" "(some \"x\")" "f32" "4.5"; want "s" "(\"Shape.Rect.w\")" "i32" "3"; + (* A package's type is its qualified name, in the inspector and in + the listing both, as a field's and a condition's already are: + two packages may each declare a Box. *) + want "pk" "()" "shape/Box" "(shape/Box {.w 3 .h 4})"; + (match Wire.field listing "locals" with + | Some { Form.v = Form.List l; _ } + when List.exists + (fun (e : Form.t) -> + match e.Form.v with + | Form.List + ({ Form.v = Form.Str "pk"; _ } + :: { Form.v = Form.Str "shape/Box"; _ } :: _) -> true + | _ -> false) + l -> () + | _ -> fail "the listing does not name pk's type as shape/Box"); (* Where each value is stored. The struct and its first field share an address and the second field is one f32 further on, so the number is the layout's and not a label. *) @@ -4372,6 +4666,7 @@ let () = end else begin let c = connect sigsock in + stepper_checks ~what:"llvm " (request c); let stopped r = match Wire.field r "stopped" with | Some { Form.v = Form.Sym "t"; _ } -> true @@ -4836,6 +5131,13 @@ let () = if not (List.exists (String.equal "continue") names) then fail "a break at (pause) offers %s, wanted continue among them" (String.concat ", " names); + (* [step] has no slots at all, so there is nothing to bind and no + table for the program to answer from: an expression evaluated + in its frame sees the globals. Frame 0 is [pause]'s own. *) + (let r = ask "(:op \"eval-expr\" :frame 1 :code \"(+ ticks 0)\")" in + if status r <> "ok" then + fail "eval-in-frame of a frame with no slots: %s" + (Option.value ~default:(status r) (Wire.string_field r "message"))); (* The second claim, and the one this block exists for. A plain re-evaluation of the same form replaces the stored declaration @@ -4881,6 +5183,7 @@ let () = end end end; + stepper_checks ~what:"x86 " ask; (* The other way a thunk reaches a [(pause)], and the one no flag asks for: an ordinary [C-x C-e] over an expression that calls a body @@ -5161,20 +5464,124 @@ let () = ignore (ask "(:op \"describe\")"); contains_sub (Buffer.contents seen) "42")) then fail "--two-process: the reload was never installed"; - (* And the one verb this shape cannot have. Running [main] again means - waking a thread that parked inside this process, and here the program - is a child: when it finishes it is gone, and there is nothing to wake. - Refused by naming what this daemon is rather than with the message a - merged one gives, because "the program is already running" would send - somebody back to try again after it had exited — and [--x86] arrives - here too, since it refuses the merged daemon for the -rdynamic reason - given below. *) + (* A re-run here is a new process. Refused while the child runs; once + it has finished, the program is built again from the session, so the + redefined [step] is what the new run's first line prints — the host + the daemon started with would print 1. *) let r = ask "(:op \"rerun\")" in let why = Option.value ~default:(status r) (Wire.string_field r "message") in - if status r <> "error" then - fail "--two-process answered a rerun it cannot perform" - else if not (contains_sub why "two-process") then - fail "--two-process refuses a rerun as: %s" why; + if status r <> "error" || not (contains_sub why "still running") then + fail "--two-process: a rerun while the child runs answered %s: %s" + (status r) why; + (* Two more deliveries take the program past its last two waits. *) + List.iter + (fun n -> + let r = + ask + (Printf.sprintf + "(:op \"eval\" :code \"(defn step [] i64 %d)\" \ + :file \"/tmp/buf.flan\")" n) + in + if status r <> "ok" then fail "--two-process: eval %d was refused" n; + if not + (await (fun () -> + ignore (ask "(:op \"describe\")"); + contains_sub (Buffer.contents seen) (string_of_int n))) + then fail "--two-process: %d was never installed" n) + [ 43; 44 ]; + (* 44 was the old child's last line, so anything from here on is the + new child's. *) + Buffer.clear seen; + let taken = ref (ask "(:op \"describe\")") in + if not + (await ~ms:10000 (fun () -> + taken := ask "(:op \"rerun\")"; + status !taken = "ok")) + then + fail "--two-process: a rerun after the child finished: %s" + (Option.value ~default:(status !taken) + (Wire.string_field !taken "message")) + else begin + let note = Option.value ~default:"" (Wire.string_field !taken "note") in + if not (contains_sub note "globals start over") then + fail "--two-process: the rerun's note does not say the globals \ + start over: %S" note; + if not + (await (fun () -> + ignore (ask "(:op \"describe\")"); + contains_sub (Buffer.contents seen) "\n")) + then fail "--two-process: the new child printed nothing" + else if not (String.starts_with ~prefix:"44\n" (Buffer.contents seen)) + then + fail "--two-process: the new child did not start with the \ + redefinition: %S" (Buffer.contents seen); + (* And it is reachable: a delivery to the new child installs. *) + let r = + ask + "(:op \"eval\" :code \"(defn step [] i64 45)\" :file \"/tmp/buf.flan\")" + in + if status r <> "ok" then fail "--two-process: eval after rerun refused"; + if not + (await (fun () -> + ignore (ask "(:op \"describe\")"); + contains_sub (Buffer.contents seen) "45")) + then fail "--two-process: the new child never installed a delivery"; + (* A signature change leaves [user] compiled for the old one. The + next build is of the whole program, so the re-run is refused at + the stale call; a fix evaluated while the child has ended goes + into the session, and the re-run after it builds. *) + let ev code = + ask + (Printf.sprintf "(:op \"eval\" :code %s :file \"/tmp/buf.flan\")" + (Wire.quote code)) + in + let alive () = + match Wire.field (ask "(:op \"describe\")") "alive" with + | Some { Form.v = Form.Sym "nil"; _ } -> false + | _ -> true + in + List.iter + (fun code -> + if status (ev code) <> "ok" then + fail "--two-process: %s was refused" code) + [ "(defn helper [] i64 1)"; "(defn user [] i64 (helper))" ]; + if not (await ~ms:10000 (fun () -> not (alive ()))) then + fail "--two-process: the new child did not finish" + else begin + let r = ev "(defn helper [x i64] i64 x)" in + if status r <> "ok" then + fail "--two-process: a change while the child has ended: %s" + (Option.value ~default:"" (Wire.string_field r "message")); + let r = ask "(:op \"rerun\")" in + if status r <> "error" + || not (contains_sub + (Option.value ~default:"" (Wire.string_field r "loc")) + "/tmp/buf.flan:1:") + then + fail "--two-process: a re-run over a stale caller answered %s \ + (%s)" (status r) + (Option.value ~default:"" (Wire.string_field r "message")); + List.iter + (fun code -> + if status (ev code) <> "ok" then + fail "--two-process: %s was refused" code) + [ "(defn user [] i64 (helper 5))"; "(defn step [] i64 (user))" ]; + Buffer.clear seen; + let r = ask "(:op \"rerun\")" in + if status r <> "ok" then + fail "--two-process: the re-run after the fix: %s" + (Option.value ~default:"" (Wire.string_field r "message")) + else if not + (await (fun () -> + ignore (ask "(:op \"describe\")"); + contains_sub (Buffer.contents seen) "\n")) + || not (String.starts_with ~prefix:"5\n" + (Buffer.contents seen)) + then + fail "--two-process: the fixed program printed %S" + (Buffer.contents seen) + end + end; ignore (ask "(:op \"close\")"); Unix.close tc end; @@ -6181,6 +6588,7 @@ let () = (String.concat ", " (List.map (fun (n, w, _) -> n ^ ": " ^ w) (triples r "refused"))) end; + eval_in_frame_checks ~backend:"x86" (request c); (* One slot by index, which is the inspector's own root rather than [locals]' listing, and an aggregate for it: an x86 frame passes every aggregate by pointer, so a struct is where a recorded address could @@ -6595,12 +7003,12 @@ let () = let answer r = Option.value ~default:"" (Wire.string_field r "value") in - let read () = - answer - (request c - "(:op \"eval-expr\" :code \"(get config :s)\" \ - :file \"programs/dev-dyn-global.flan\")") + let read_reply () = + request c + "(:op \"eval-expr\" :code \"(get config :s)\" \ + :file \"programs/dev-dyn-global.flan\")" in + let read () = answer (read_reply ()) in (* A hundred thousand small maps: flan_dyn.c collects at a one-megabyte floor, so this is several collections and not a heap that merely grew. *) @@ -6620,11 +7028,17 @@ let () = if status r <> "ok" then fail "--%s: the churning thunk (cycle %d): %s" backend cycle (said r) - else if not (contains_sub (read ()) "kept") then - fail - "--%s: after a thunk that allocates (cycle %d) the parked \ - program's dyn global reads %S" - backend cycle (read ()); + else begin + (* The failing reply itself, and not a second read: the one + recorded failure here re-read and got "kept", so what the + first read answered is the whole of the evidence. *) + let r = read_reply () in + if not (contains_sub (answer r) "kept") then + fail + "--%s: after a thunk that allocates (cycle %d) the \ + parked program's dyn global read %S (%s: %s)" + backend cycle (answer r) (status r) (said r) + end; (* And round main again, which re-enters the very code that pushed those roots. *) let r = request c "(:op \"rerun\")" in @@ -6633,7 +7047,79 @@ let () = if not (await ~ms:20000 parked) then fail "--%s: the program did not park again (cycle %d)" backend cycle - done + done; + (* An expression's module is unloaded once it returns, string + literals and all: a literal is a copy the process keeps, so a + global left holding one still reads it after the module that + wrote it is gone and later ones have been mapped where it + was. The mapping count is what the kernel limits. *) + let ev code = + request c + (Printf.sprintf + "(:op \"eval-expr\" :code %s \ + :file \"programs/dev-dyn-global.flan\")" (Wire.quote code)) + in + let r = + request c + "(:op \"eval\" :code \"(defonce msg string)\" \ + :file \"programs/dev-dyn-global.flan\")" + in + if status r <> "ok" then fail "--%s: defonce msg: %s" backend (said r) + else begin + ignore (ev "(do (set msg \"tuned\") 0)"); + let maps () = + List.length + (String.split_on_char '\n' + (In_channel.with_open_bin + (Printf.sprintf "/proc/%d/maps" dpid) + In_channel.input_all)) + in + let m0 = maps () in + for i = 1 to 20 do + ignore (ev (Printf.sprintf "(do (println \"other %d\") %d)" i i)) + done; + let m1 = maps () in + if m1 - m0 >= 20 then + fail "--%s: twenty expressions with a string literal left %d \ + more mappings" backend (m1 - m0); + let r = ev "msg" in + if Wire.string_field r "value" <> Some "\"tuned\"" then + fail "--%s: a literal stored by an unloaded module reads %S \ + (%s)" backend + (Option.value ~default:"" (Wire.string_field r "value")) + (said r) + end; + (* A function value an expression makes has its code in that + expression's module — a lambda's body, or the wrapper a named + function is handed out through — so that module stays mapped. + Later expressions are mapped between the store and the call, + where an unloaded one would have been. *) + let defd code = + let r = + request c + (Printf.sprintf + "(:op \"eval\" :code %s \ + :file \"programs/dev-dyn-global.flan\")" (Wire.quote code)) + in + if status r <> "ok" then fail "--%s: %s: %s" backend code (said r) + in + defd "(defonce kept (Option (Fn [i64] i64)))"; + defd "(defn twice [x i64] i64 (* x 2))"; + let call_kept want what = + for i = 1 to 3 do + ignore (ev (Printf.sprintf "(do (println \"pad %d\") %d)" i i)) + done; + let r = ev "(match kept (Some f) (f 1) (None) -1)" in + if Wire.string_field r "value" <> Some want then + fail "--%s: %s kept by an unloaded expression answered %S \ + (%s)" backend what + (Option.value ~default:"" (Wire.string_field r "value")) + (said r) + in + ignore (ev "(do (set kept (Some (fn [x] (+ x 7)))) 0)"); + call_kept "8" "a lambda"; + ignore (ev "(do (set kept (Some twice)) 0)"); + call_kept "2" "a named function" end; ignore (request c "(:op \"close\")"); (try Unix.close c with Unix.Unix_error _ -> ()); @@ -8752,6 +9238,110 @@ let () = hook_block ~llvm:false; hook_block ~llvm:true; + (* ── --sanitize on the backend it cannot instrument ───────────── *) + + (* Refused before anything is built, by name and with the way out. The + session itself is driven under the sanitizers by @sanitize. *) + let zerr = tmp "x86san.err" in + let zfd = Unix.openfile zerr [ Unix.O_WRONLY; Unix.O_CREAT; Unix.O_TRUNC ] 0o600 in + let zpid = + Unix.create_process flan + [| flan; "dev"; "programs/dev-loop.flan"; "-s"; tmp "x86san.sock"; + "--x86"; "--sanitize" |] + Unix.stdin zfd zfd + in + Unix.close zfd; + (match Unix.waitpid [] zpid with + | _, Unix.WEXITED 1 -> + let said = In_channel.with_open_bin zerr In_channel.input_all in + if not (contains_sub said "--x86 --sanitize" + && contains_sub said "Drop --x86") then + fail "flan dev --x86 --sanitize was refused as: %S" said + | _ -> fail "flan dev --x86 --sanitize was not refused"); + (try Sys.remove zerr with Sys_error _ -> ()); + + (* ── Whose break it is ─────────────────────────────────────────── *) + + (* The program stops on its own while an evaluation is in flight: [go] + makes it sleep for longer than a module takes to build and then + signal, without polling in between. The stop is fresh, as a thunk's + would be, and it is not the expression's; the expression runs inside + the program's break loop and its value is the answer. On the default + backend, because the stop's owner is the agent's and not the + backend's. *) + let osock = tmp "ownbreak.sock" and oout = tmp "ownbreak.out" in + (try Sys.remove osock with Sys_error _ -> ()); + let ofd = Unix.openfile oout [ Unix.O_WRONLY; Unix.O_CREAT; Unix.O_TRUNC ] 0o600 in + let opid = + Unix.create_process flan + [| flan; "dev"; "programs/dev-own-break.flan"; "-s"; osock |] + Unix.stdin ofd Unix.stderr + in + Unix.close ofd; + if not (listening ~pid:opid osock) then begin + fail "the own-break daemon %s" !listen_why; + (try Unix.kill opid Sys.sigkill with Unix.Unix_error _ -> ()) + end + else begin + let c = connect osock in + let said r = + Option.value ~default:(status r) (Wire.string_field r "message") + in + let ev code = + request c + (Printf.sprintf + "(:op \"eval-expr\" :code %s :file \"programs/dev-own-break.flan\")" + (Wire.quote code)) + in + (* An expression stopped in a break and resumed by a restart finishes + after the restart's reply, and here it finishes after the next + expression has been sent: its value must not answer for that one. *) + let r = + ev "(restart-case (do (error (Late {})) 0) \ + (slow [] (do (usleep 500000) 5)))" + in + if status r <> "error" then + fail "resumed value: the first expression did not stop: %s" (said r) + else begin + let r = request c "(:op \"restart\" :name \"slow\")" in + if status r <> "ok" then fail "resumed value: restart: %s" (said r); + let r = ev "(do (usleep 300000) 23)" in + if Wire.string_field r "value" <> Some "23" then + fail "resumed value: the next expression answered %S (%s)" + (Option.value ~default:"" (Wire.string_field r "value")) (said r) + end; + let r = ev "(do (set go 1) 0)" in + if status r <> "ok" then fail "own break: setting go: %s" (said r) + else begin + (* The sleep keeps the thunk running inside the program's break for + many of the daemon's ticks, so a wait that took any fresh stop for + the thunk's would answer before the value exists. *) + let r = ev "(do (usleep 300000) 42)" in + if status r <> "ok" + || Wire.string_field r "value" <> Some "42" then + fail "own break: an expression in flight when the program stopped \ + on its own answered %s %S (value %S)" + (status r) (said r) + (Option.value ~default:"" (Wire.string_field r "value")); + (match Wire.field r "condition" with + | Some { Form.v = Form.Str "Late"; _ } -> () + | _ -> fail "own break: the reply does not carry the program's stop") + end; + ignore (aborted c); + (try Unix.close c with Unix.Unix_error _ -> ()); + if not + (await ~ms:10000 (fun () -> + match Unix.waitpid [ Unix.WNOHANG ] opid with + | 0, _ -> false + | _ -> true)) + then begin + fail "own break: the daemon did not end on abort"; + (try Unix.kill opid Sys.sigkill with Unix.Unix_error _ -> ()); + (try ignore (Unix.waitpid [] opid) with Unix.Unix_error _ -> ()) + end + end; + List.iter (fun f -> try Sys.remove f with Sys_error _ -> ()) [ osock; oout ]; + List.iter (fun f -> try Sys.remove f with Sys_error _ -> ()) [ sock; out; bsock; bout ]; Test_support.report ~label:"dev" () diff --git a/test/test_flan.ml b/test/test_flan.ml index 4d0f57f7..1e151779 100644 --- a/test/test_flan.ml +++ b/test/test_flan.ml @@ -1417,7 +1417,7 @@ let () = accepts "all-distinct over a type variable" "(defn three [a $t b $t c $t] bool {:where (equal? $t)} (!= a b c))"; rejects_check "a chain still wants the right predicate" - ~needle:"nothing declares t ordered?" + ~needle:"nothing declares $t ordered?" "(defn between [a $t b $t c $t] bool {:where (equal? $t)} (< a b c))"; (* One operand and none. Both would have to be [true] whatever they were handed, which is a typo carrying a value. *) @@ -1470,10 +1470,10 @@ let () = can actually be written there; the parameter-vector suggestion survives where it works, which the return-type pin further down exercises. *) rejects_check "a real type variable at a field" "(defstruct Holder [x elem])" - ~needle:"a field is built at one type for every value"; + ~needle:"in a defstruct's fields that makes the struct generic over it"; rejects_check "and the field message offers what a field can hold" "(defstruct Holder [x elem])" - ~needle:"Write a concrete type here, or dyn to hold any value"; + ~needle:"Write $elem, a concrete type, or dyn to hold any value"; rejects_check "an unknown concrete type" "(defn f [x Widget] ())" ~needle:"unknown type Widget"; @@ -2508,12 +2508,14 @@ let () = rejects_check "slice-from-ptr with a negative literal length" "(defn f [p (Ptr i32)] i32 (length (slice-from-ptr p -1)))" ~needle:"is negative"; - (* The storage stays C's. A slice carries no allocator, so free refuses one - by the rule it already had — this pins that the new form did not become - a thing anybody could hand to free. *) + (* The storage stays C's, and a view made in place is refused at free + without running anything. *) rejects_check "free of a slice made from a pointer" "(defn f [p (Ptr i32)] () (free (slice-from-ptr p 3)))" - ~needle:"free takes an owning container"; + ~needle:"is a view of storage something else owns"; + rejects_check "free of a slice written in place" + "(defn f [v (Vec i32)] () (free (slice v)))" + ~needle:"is a view of storage something else owns"; (* ── Structs, fields and auto-deref ────────────────────────────── *) let cursor = "(defstruct Cursor [src [u8] pos i32]) " in @@ -2871,13 +2873,11 @@ let () = (* [(Pair i32)] in a defonce falls down the value fork now that the third element takes either reading, and the generics answer the type fork gave it has to be reachable from here too. *) - (* A capitalised head with arguments is a *type* given type arguments, and - that is the half of generics that is not built — Types.Named is a bare - string with no room for parameters. The sentence says which half, since - generic functions are here and pointing at them is the useful part. *) + (* A capitalised head with arguments is a *type* given type arguments; with + no such struct declared, the sentence says how one is. *) rejects_check "a capitalised call with arguments is a generic type" "(defonce x (Pair i32)) (defn f [] i32 0)" - ~needle:"is a generic type, which is not there yet"; + ~needle:"no struct or generic struct Pair is declared"; accepts "and the generic function it points at is" "(defn pair-fst [a $t b $u] $t (do b a))\n\ (defn main [] () (println (pair-fst 1 true)))"; @@ -3188,6 +3188,45 @@ let () = rejects_check "clone on a slice of owning elements" "(defn f [v [(Vec i32)]] i32 (length (clone v)))" ~needle:"[(Vec i32)] cannot be cloned"; + (* into with no (map f) pushes the source's elements as they stand, which + for an owning element shares its block — pushing through the copy then + frees the source's. The fix it names is programs/into-owning.flan. *) + rejects_check "into copying owning elements, refused at the source" + "(defn f [a Allocator] i32\n\ + \ (let [v (vec-new (Vec i32) a)\n\ + \ w (into v (vec-new (Vec i32) a) (filter nonempty?))] (length w)))\n\ + (defn nonempty? [x (Vec i32)] bool (> (length x) 0))" + ~needle:"into copies each element of v as it stands, and an element of v \ + is a (Vec i32), which owns storage — the copy would share each \ + element's block with v, and growing either one frees the block \ + the other points at. Add (map clone) to the chain, which copies \ + what each element owns: (into v (vec-new (Vec i32) a) (filter \ + nonempty?) (map clone))"; + accepts "into with (map clone) over owning elements" + "(defn f [a Allocator] i32\n\ + \ (let [v (vec-new (Vec i32) a)\n\ + \ w (into v (vec-new (Vec i32) a) (map clone))] (length w)))"; + accepts "into of plain elements is untouched" + "(defn f [v [i32]] () (let [w (into v (vec-new i32))] (free w)))"; + rejects_check "into copying elements clone cannot copy, explained" + "(defstruct B [xs (Vec i32)])\n\ + (defn f [v [B] a Allocator] i32 (let [w (into v (vec-new B a))] (length w)))" + ~needle:"Nothing copies what a B owns, so no copy of v can stand on its \ + own"; + rejects_check "clone's refusal names a clone of each element" + "(defn f [v [(Vec i32)]] i32 (length (clone v)))" + ~needle:"push a (clone x) of each element into it"; + (* A program's names cannot change what the prelude means: a global or a + type spelled like a built-in type is refused where it is declared, and + the rest are programs/prelude-names.flan. *) + rejects_check "a global named like a built-in type" + "(defonce u8 i32)" + ~needle:"u8 is a type, so it cannot also name a global"; + rejects_check "a type named like a built-in type" + "(defstruct i32 [x i32])" + ~needle:"i32 is a built-in type, so it cannot be declared again"; + accepts "a global and a type named after the prelude's type variables" + "(defonce t [4 i32])\n(defstruct k [x i32])\n(defenum v [lo hi])"; accepts "clone on a slice, with and without an allocator" "(defn f [v [f64] a Allocator] i32 (+ (length (clone v)) (length (clone v a))))"; @@ -3567,6 +3606,23 @@ let () = "(defn h [x i32] i32 x) (defn g [i i32] (Fn [i32] i32) h)\n\ (defn f [] i32 (let [a (array-gen [2] g)] 0))" ~needle:"a fixed array's element cannot be (Fn [i32] i32)"; + (* A (CFn ...) is not refused in any of them: a call through one tests for + null and signals NullCall, so its zero is an empty slot. *) + accepts "a CFn struct field" + "(defstruct Ops [run (CFn [i32] i32)])\n\ + (defn f [o Ops] i32 ((.run o) 1))"; + accepts "a fixed array of CFn" + "(defonce tbl [4 (CFn [i32] i32)])\n(defn f [] i32 ((at tbl 0) 1))"; + accepts "a CFn global with no initialiser" + "(defonce hook (CFn [] ()))\n(defn f [] () (hook))"; + accepts "(zeroed) at a CFn" + "(defn f [] i32 (let [g (the (CFn [i32] i32) (zeroed))] (g 1)))"; + accepts "an array-gen of CFn" + "(defn h [x i32] i32 x) (defn g [i i32] (CFn [i32] i32) h)\n\ + (defn f [] i32 (let [a (array-gen [2] g)] ((at a 1) 3)))"; + rejects_check "an Fn struct field is still refused" + "(defstruct Ops [run (Fn [i32] i32)])" + ~needle:"the field run cannot be (Fn [i32] i32)"; (* The inline form, the design's canonical one. An fn normally takes its types from a (Fn ...) want, and this position has none — the *form* @@ -5637,6 +5693,42 @@ let () = rejects_check "and offers no comparison at all for a type that has none" "(defstruct P [x i32]) (defn f [] i32 (let [p (P {.x 1})] (if p 1 0)))" ~needle:"a condition is a bool or a dyn, and this is P"; + (* A deep nest of not over a condition that is refused. Each level retries + the level below it for its message, and a refusal already settled is + answered from memory, so two hundred levels fail at once — re-walking + each subtree doubled the work per level. The message is the innermost + condition's, as it is at one level. *) + (let deep = + let rec nest k e = if k = 0 then e else nest (k - 1) ("(not " ^ e ^ ")") in + "(defn g [x i32] bool " ^ nest 200 "x" ^ ")" + in + let t0 = Unix.gettimeofday () in + match checked deep with + | _ -> check "a deep not nest over an i32 is refused" false + | exception Loc.Error { Loc.dmsg; _ } -> + check "a deep not nest over an i32 fails fast" + (Unix.gettimeofday () -. t0 < 3.0); + check "a deep not nest keeps the one-level message" + (dmsg = "a condition is a bool or a dyn, and this is i32 — test it, as \ + (!= x 0)")); + (* A long or chain refused at its last operand, with nothing expected of it. + Each if tries its else arm on its own terms before checking it at bool, + and a refused if is answered from memory, so a thousand operands fail + at once rather than in the square of that. *) + (let deep = + "(defn g [x i32] bool (let [b (or " + ^ String.concat " " (List.init 1000 (Printf.sprintf "(= x %d)")) + ^ " 5)] b))" + in + (* Timed rather than under [Watchdog.within]: a catch-all inside the + checker can swallow the alarm's exception. *) + let t0 = Unix.gettimeofday () in + match checked deep with + | _ -> check "a refused or chain is refused" false + | exception Loc.Error { Loc.dmsg; _ } -> + check "a refused or chain fails fast" (Unix.gettimeofday () -. t0 < 3.0); + check "a refused or chain keeps the one-operand message" + (dmsg = "expected bool, found the integer literal 5")); (* A literal still names itself: that message knows something the rule does not, so the re-check's answer is kept wherever it is more specific. *) rejects_check "a literal condition keeps its own message" @@ -5752,6 +5844,97 @@ let () = (match checked shadow_src with | _ -> true | exception Loc.Error _ -> false); + (* A parameter vector paired by a lowercase type the program declares reads + as two dyn parameters the day the type goes, so the pairing is warned at, + naming the type and where it is declared. A capitalised type cannot be a + parameter name, so it has nothing to warn about. *) + (match + checked "(defstruct point [x i32])\n(defstruct Vec2 [x i32])\n\ + (defn px [p point] i32 (.x p))\n(defn vx [v Vec2] i32 (.x v))" + with + | _ -> + (match !Check.pairing_warnings with + | [ d ] -> + check "a lowercase declared type in a parameter vector is warned at" + (d.Loc.kind = "check/parameter-reads-a-type" + && d.Loc.dloc.Loc.line = 3 && d.Loc.dloc.Loc.col = 13 + && d.Loc.dmsg + = "[p point] is one parameter p of type point, the struct \ + declared at :1:1, and not two dyn parameters. If two \ + were meant, give the second a name no type has") + | ds -> + check + (Printf.sprintf "one pairing warning, not %d" (List.length ds)) + false) + | exception Loc.Error _ -> check "the paired program checks" false); + (* A Vec or Map parameter is the caller's header copied, so growing it is + warned at the parameter, once, naming the (Ptr ...) that reaches the + caller's own. A pointer parameter and a local are not warned at. The + running side is programs/grow-param.flan. *) + let grown src = + match checked src with + | _ -> Some !Check.grow_warnings + | exception Loc.Error _ -> None + in + (match + grown "(defn f [v (Vec i32) m (Map i32 i32)] ()\n\ + \ (push v 1) (reserve v 8) (put m 1 2))" + with + | Some [ dm; dv ] -> + check "a grown Vec parameter is warned at the parameter" + (dv.Loc.kind = "check/grown-parameter" + && dv.Loc.dloc.Loc.line = 1 && dv.Loc.dloc.Loc.col = 10 + && dv.Loc.dmsg + = "v is a (Vec i32) passed by value, a copy of the caller's header, \ + so the push at :2:3 grows this function's copy and the \ + caller's container never sees it. Take it as (Ptr (Vec i32)) \ + and write (push (deref v) ...), and each caller passes (addr c) \ + for its container c"); + check "and a grown Map parameter names put" + (dm.Loc.dloc.Loc.col = 22 + && Test_support.contains dm.Loc.dmsg "the put at :2:28") + | Some ds -> + check (Printf.sprintf "two grow warnings, not %d" (List.length ds)) false + | None -> check "the grown-parameter program checks" false); + (* A struct parameter is a copy with its Vec fields in it, through any + depth of fields taken by value; through a pointer, not. *) + (match + grown "(defstruct Bag [items (Vec i32)])\n(defstruct Box [bag Bag])\n\ + (defn f [x Box] () (push (.items (.bag x)) 1))\n\ + (defn g [x (Ptr Box)] () (push (.items (.bag x)) 1))" + with + | Some [ d ] -> + check "a grown field of a struct parameter is warned at the parameter" + (d.Loc.dloc.Loc.line = 3 && d.Loc.dloc.Loc.col = 10 + && d.Loc.dmsg + = "x is a Box passed by value, a copy of the caller's, so the push \ + at :3:20 grows (.items (.bag x)) in this function's copy \ + and the caller's never sees it. Take it as (Ptr Box), where \ + (.items (.bag x)) reaches the caller's own, and each caller \ + passes (addr c) for its Box c") + | Some ds -> + check (Printf.sprintf "one field grow warning, not %d" (List.length ds)) false + | None -> check "the grown-field program checks" false); + (* Not when the grown copy goes back to the caller — the parameter, or the + struct holding the field, is what the function answers — nor when the + field is given a container of the function's own before it grows. *) + check "a grown parameter the function returns is not warned at" + (grown "(defstruct Bag [items (Vec i32)])\n\ + (defn add [v (Vec i32) x i32] (Vec i32) (push v x) v)\n\ + (defn early [v (Vec i32) c bool] (Vec i32) (push v 1) \ + (when c (return v)) v)\n\ + (defn bag [b Bag] Bag (push (.items b) 1) b)\n\ + (defn items [b Bag] (Vec i32) (push (.items b) 1) (.items b))" + = Some []); + check "a field reassigned before it grows is not warned at" + (grown "(defstruct Bag [items (Vec i32)])\n\ + (defn f [b Bag] ()\n\ + \ (set (.items b) (vec-new i32)) (push (.items b) 1) (free (.items b)))" + = Some []); + check "a pointer parameter and a local are not warned at" + (grown "(defn f [v (Ptr (Vec i32))] ()\n\ + \ (push (deref v) 1) (let [w (vec-new i32)] (push w 1) (free w)))" + = Some []); check "a program that shadows nothing is warned at not at all" (Check.shadowed_builtins (program "(defn f [] i32 1)") = []); (* A prelude function's name is taken over the same way, for the calls in @@ -5770,6 +5953,20 @@ let () = | _ -> check "a defn of a prelude function's name warns exactly once" false); accepts "a defn of a prelude function's name is not defined twice" prelude_src; + (* A global takes the name over the same way, with the same warning. *) + (match + snd (Check.shadow_prelude (Parse.program (Prelude.forms ())) + (program "(defonce swap i32 3)")) + with + | [ d ] -> + check "a global of a prelude function's name warns once" + (d.Loc.kind = "check/shadows-prelude" + && d.Loc.dmsg + = "swap shadows the prelude's swap — every use in this file now \ + reaches your definition") + | _ -> check "a global of a prelude function's name warns exactly once" false); + accepts "a global of a prelude function's name is not defined twice" + "(defonce swap i32 3)\n(defn f [] i32 swap)"; rejects_check "a struct of a prelude type's name is still defined twice" "(defstruct Form [x i32])" ~needle:"Form is defined twice"; (* An operator is a builtin like any other and shadows like any other. @@ -5988,6 +6185,110 @@ let () = check "and they are in source order" (List.map (fun (d : Loc.diag) -> d.Loc.dloc.Loc.line) ds = [ 1; 2; 3 ])); + (* A generic whose abstract pass was refused is not checked again at each + copy: the refusal is one error, however many types call it, and the + caller's own later refusal is still found. *) + (match + Check.program_all + (Parse.program_all + (read "(defn g [x $t] u64 (nosuch x))\n\ + (defn main [] i32 (g 3) (g true) nope 0)\n")) + with + | _ -> check "a refused generic body is refused" false + | exception Loc.Errors ds -> + check "a refused generic body is one error, and its caller's is another" + (List.map (fun (d : Loc.diag) -> d.Loc.dloc.Loc.line) ds = [ 1; 2 ])); + + (* A refusal inside a copy names the call that asked for it, and each copy + between: the chain walks back to the line the programmer wrote. *) + (match + checked + "(defn show [v $t] () (println v)) \ + (defn outer [v $t] () (show v)) \ + (defn main [] i32 (outer main) 0)" + with + | _ -> check "a copy with no printer is refused" false + | exception Loc.Error d -> + let notes = List.map (fun (n : Loc.note) -> n.Loc.nmsg) d.Loc.notes in + check "a refusal in a copy names both instantiations" + (contains d.Loc.dmsg "no printer for" + && notes + = [ "show is instantiated at $t = (CFn [] i32) here"; + "outer is instantiated at $t = (CFn [] i32) here" ])); + + (* A refusal made while collecting declarations — a generic struct that + holds itself, one that grows without end, a where clause over a length — + is one error among the rest of the file's, not the end of the check. *) + let all_lines src = + match Check.program_all (Parse.program_all (read src)) with + | _ -> [] + | exception Loc.Errors ds -> + List.map (fun (d : Loc.diag) -> d.Loc.dloc.Loc.line) ds + in + check "a self-containing generic struct is one error of several" + (all_lines + "(defstruct Loop [next (Loop $t)])\n\ + (defn g [] i32 (let [p (the (Loop i32) (zeroed))] nope1))\n\ + (defn h [] i32 nope2)\n" + = [ 1; 2; 3 ]); + check "a generic struct that grows without end is one error of several" + (all_lines + "(defstruct Grow [next (Ptr (Grow [$t]))])\n\ + (defn g [] i32 (let [p (the (Grow i32) (zeroed))] nope1))\n\ + (defn h [] i32 nope2)\n" + = [ 1; 2; 3 ]); + check "a where clause over a length is one error of several" + (all_lines + "(defn f [a [$n i32]] i32 {:where (numeric? $n)} nope1)\n\ + (defn h [] i32 nope2)\n" + = [ 1; 1; 2 ]); + (* A literal that does not fit what a typed field decided names that field. *) + (match + checked + "(defstruct Pair [a $t b $t]) \ + (defn main [] i32 (let [p (Pair (the i32 1) 2.5)] 0))" + with + | _ -> check "a float literal where a typed field decided i32" false + | exception Loc.Error d -> + check "the refusal names the field that decided the variable" + (contains d.Loc.dmsg "Pair's .b is $t, which is i32 here" + && List.exists + (fun (n : Loc.note) -> + contains n.Loc.nmsg ".a is i32 here, which decides $t") + d.Loc.notes)); + + (* A copy that cannot be built at a closure's type: the zeroed value in the + body is refused there, and the call that asked is named. *) + (match + checked + "(defn blank [x $t] $t (let [z (the $t (zeroed))] z)) \ + (defn use-it [f (Fn [i32] i32)] i32 (blank f) 0)" + with + | _ -> check "a zeroed closure in a copy is refused" false + | exception Loc.Error d -> + check "a copy at a closure type names the call that asked" + (List.exists + (fun (n : Loc.note) -> + contains n.Loc.nmsg "blank is instantiated at $t = (Fn [i32] i32) here") + d.Loc.notes)); + + (* A prelude generic's body is nobody's source at the call: the refusal is + at the call, and the prelude's line is a note. *) + (match + checked + "(defn keep [g (Vec u8)] bool true) \ + (defn use-it [xs [(Vec u8)]] i32 (length (filter xs keep)))" + with + | _ -> check "a prelude copy that cannot be built is refused" false + | exception Loc.Error d -> + check "a prelude copy's refusal is at the user's call" + (d.Loc.dloc.Loc.file <> Prelude.file + && contains d.Loc.dmsg "filter cannot be made at $t = (Vec u8)" + && not (contains d.Loc.dmsg "clone") + && List.exists + (fun (n : Loc.note) -> n.Loc.nloc.Loc.file = Prelude.file) + d.Loc.notes)); + (* The parser resynchronises on a top-level form, so two bad declarations are two errors rather than one. *) (match Parse.program_all (read "(defn a)\n(defn b)\n") with @@ -6046,7 +6347,7 @@ let () = accepts "numeric? admits +" "(defn add [a $t b $t] $t {:where (numeric? $t)} (+ a b))"; rejects_check "equal? does not admit <" - ~needle:"nothing declares t ordered?" + ~needle:"nothing declares $t ordered?" "(defn less [a $t b $t] bool {:where (equal? $t)} (< a b))"; (* The entailments, which are the reason a signature is one predicate long rather than two. Every type the language orders is a number or an enum, @@ -6074,10 +6375,10 @@ let () = accepts "integer? admits the shifts" "(defn dbl [x $t] $t {:where (integer? $t)} (<< x 1))"; rejects_check "numeric? does not admit bit-and" - ~needle:"nothing declares t integer?" + ~needle:"nothing declares $t integer?" "(defn low? [x $t] bool {:where (numeric? $t)} (= (bit-and x 1) 1))"; rejects_check "nor the shifts" - ~needle:"nothing declares t integer?" + ~needle:"nothing declares $t integer?" "(defn dbl [x $t] $t {:where (numeric? $t)} (<< x 1))"; (* An integer?-bounded caller satisfies a numeric?-bounded callee: the entailment carries across generic calls exactly as ordered?-over-equal? @@ -6143,7 +6444,8 @@ let () = and the message says which predicate to write. *) rejects_check "ordered? does not admit a conversion" ~needle:"The where clause says t is ordered?, and that does not make it \ - a number — add (numeric? $t) to the where clause" + a number or an enum — add (numeric? $t) to the where clause, or \ + (enum? $t) for an enum" "(defn to32 [x $t] i32 {:where (ordered? $t)} (i32 x))"; rejects_check "nor does equal?" ~needle:"add (numeric? $t) to the where clause" @@ -6154,9 +6456,28 @@ let () = (* With no clause at all the message hands over the whole clause rather than a predicate to add to one that is not there. *) rejects_check "an unbounded variable does not convert" - ~needle:"i32 converts a number. Nothing here says t is a number — write \ - {:where (numeric? $t)} at the head of the body" + ~needle:"i32 converts a number or an enum. Nothing here says t is a \ + number or an enum — write {:where (numeric? $t)} at the head of \ + the body, or {:where (enum? $t)} for an enum" "(defn to32 [x $t] i32 (i32 x))"; + (* enum? is the other bound a conversion to a number takes: it admits the + enums, which convert as an i32, and entails ordered? and equal? but not + numeric?. The running side is programs/enum-generic.flan. *) + accepts "enum? admits the conversion from an enum" + "(defn code [x $t] i32 {:where (enum? $t)} (i32 x))"; + accepts "and compares, being ordered? and equal?" + "(defn later? [a $t b $t] bool {:where (enum? $t)} (and (> a b) (= a b)))"; + rejects_check "but is not a number" + ~needle:"$t" + "(defn sum [a $t b $t] $t {:where (enum? $t)} (+ a b))"; + rejects_check "and admits no integer at the call" + ~needle:"i32 is not enum?" + "(defn code [x $t] i32 {:where (enum? $t)} (i32 x))\n\ + (defn f [] i32 (code (i32 3)))"; + rejects_check "nor the conversion to an enum, which needs an integer" + ~needle:"add (integer? $t) to the where clause" + "(defenum K [lo -1 hi 1])\n\ + (defn as-k [n $t] K {:where (enum? $t)} (K n))"; (* The operand of a cast to a *variable* target is asked the same question the target was: the target's bound says nothing about a second variable standing in the argument. *) @@ -6660,19 +6981,118 @@ let () = bound, because inside a signature that introduces one the mistake is nearly always the second spelling of the first. *) rejects_check "vec-new over a sigil that names no variable in scope" - ~needle:"this signature introduces t, so write t here" + ~needle:"this signature introduces $t, so write $t here" "(defn f [x $t] i32 (do x (let [v (vec-new $u)] (free v) 0)))"; rejects_check "and a cast over one tells the same story" - ~needle:"this signature introduces t, so write t here" + ~needle:"this signature introduces $t, so write $t here" "(defn f [x i32 d $t] $t {:where (numeric? $t)} (do d ($u x)))"; rejects_check "two variables in scope are both named" - ~needle:"introduces t and u, so write one of those" + ~needle:"introduces $t and $u, so write one of those" "(defn f [a $t b $u] i32 (do a b (let [v (vec-new $w)] (free v) 0)))"; (* Where no variable is in scope there is none to name, and the answer is the rule: a sigil binds, and only a defn signature is a binding site. *) - rejects_check "a sigil in a struct field, where nothing can bind one" - ~needle:"only a defn signature can" - "(defstruct S [v $t])"; + rejects_check "a sigil in a data case's field, where nothing can bind one" + ~needle:"only a defn signature or a defstruct's fields can" + "(defdata D [(C [v $t])])"; + + (* ── Generic structs: what is refused, and where ─────────────────── *) + rejects_check "a generic struct given the wrong number of arguments" + ~needle:"Pair takes 1 argument, (Pair $t), and this gives 2" + "(defstruct Pair [a $t b $t]) (defn f [p (Pair i32 i64)] i32 0)"; + rejects_check "a generic struct named with no arguments" + ~needle:"Pair is generic, and a type only once it is given its arguments" + "(defstruct Pair [a $t b $t]) (defn f [p Pair] i32 0)"; + rejects_check "a type where a length argument goes" + ~needle:"Small's $n is a length" + "(defstruct Small [items [$n $t] count i32]) \ + (defn f [p (Small i32 4)] i32 0)"; + rejects_check "a length where a type argument goes" + ~needle:"Small's $t is a type, and 4 is a length" + "(defstruct Small [items [$n $t] count i32]) \ + (defn f [p (Small 4 4)] i32 0)"; + rejects_check "a negative length argument" + ~needle:"-1 is negative" + "(defstruct Small [items [$n $t] count i32]) \ + (defn f [p (Small -1 i32)] i32 0)"; + rejects_check "one variable as both a length and a type" + ~needle:"$t stands for a length in one place here and a type in another" + "(defstruct Bad [x $t y [$t i32]])"; + rejects_check "a length variable where a type goes" + ~needle:"n is a length, not a type" + "(defn f [a [$n i32]] i32 (let [x (the n 0)] 0))"; + rejects_check "a where clause over a length variable" + ~needle:"$n is a length, and a where clause takes type predicates only" + "(defn f [a [$n i32]] i32 {:where (numeric? $n)} 0)"; + rejects_check "a generic struct that contains itself by value" + ~needle:"(Loop $t) contains itself by value" + "(defstruct Loop [next (Loop $t)])"; + rejects_check "a generic struct that asks for bigger copies of itself" + ~needle:"Grow names a copy of itself at a type built around its own" + "(defstruct Grow [next (Ptr (Grow [$t]))]) (defn f [p (Grow i32)] i32 0)"; + rejects_check "a copy whose key is already a struct's name" + ~needle:"Pair at these arguments is called Pair-i32, and Pair-i32 is \ + already defined" + "(defstruct Pair [a $t b $t]) (defstruct Pair-i32 [x i32]) \ + (defn f [p (Pair i32)] i32 0)"; + rejects_check "a generic struct literal whose fields decide nothing" + ~needle:"Pair's $t is not decided by the fields given here" + "(defstruct Pair [a $t b $t]) (defn f [] i32 (let [p (Pair {})] 0))"; + rejects_check "two fields that disagree about the variable" + ~needle:"(Pair $t)'s .b is i32 here, and this is f64" + "(defstruct Pair [a $t b $t]) \ + (defn f [] i32 (let [p (Pair (the i32 1) (the f64 2.5))] 0))"; + accepts "a literal field takes its width from a typed one beside it" + "(defstruct Pair [a $t b $t]) \ + (defn f [] f64 (let [p (Pair 1 (the f64 2.5))] (.a p)))"; + rejects_check "a generic struct as a condition" + ~needle:"Pair is generic, and a condition struct is not" + "(defstruct Pair :parent Error [a $t])"; + rejects_check "an operator a generic body's struct field does not support" + ~needle:"+ over the type variable $t" + "(defstruct Pair [a $t b $t]) (defn f [p (Pair $t)] $t (+ (.a p) (.b p)))"; + accepts "the same body with the predicate declared" + "(defstruct Pair [a $t b $t]) \ + (defn f [p (Pair $t)] $t {:where (numeric? $t)} (+ (.a p) (.b p))) \ + (defn main [] i32 (f (Pair 1 2)))"; + accepts "a copy wanted where it is built takes its type from there" + "(defstruct Pair [a $t b $t]) (defn f [] (Pair i64) (Pair 1 2))"; + (* A copy whose field is refused names each use that asked for it. *) + (match + checked + "(defstruct Box [f $t]) (defstruct Outer [b (Box $w)]) \ + (defn go [g (Fn [i32] i32)] i32 \ + (.x (the (Outer (Fn [i32] i32)) (zeroed))) 0)" + with + | _ -> check "a copy with a zeroed function field is refused" false + | exception Loc.Error d -> + let notes = List.map (fun (n : Loc.note) -> n.Loc.nmsg) d.Loc.notes in + check "a refused copy names each use that made it" + (List.mem "(Box (Fn [i32] i32)) is made here" notes + && List.mem "(Outer (Fn [i32] i32)) is made here" notes)); + rejects_check "a bare generic struct in ordinary code suggests real arguments" + ~needle:"write (Pair i32)" + "(defstruct Pair [a $t b $t]) (defn main [] i32 (let [p (the Pair (zeroed))] 0))"; + rejects_check "a generic struct applied to nothing" + ~needle:"Pair takes 1 argument, (Pair $t), and this gives 0" + "(defstruct Pair [a $t b $t]) \ + (defn main [] i32 (let [p (the (Pair) (zeroed))] 0))"; + rejects_check "a length argument that is not one" + ~needle:"(+ n 1) is not a type or a length" + "(defstruct Small [items [$n $t] count i32]) \ + (defn main [] i32 (let [n 3 p (the (Small (+ n 1) i32) (zeroed))] 0))"; + accepts "a length argument of literal arithmetic is folded" + "(defstruct Small [items [$n $t] count i32]) \ + (defn main [] i32 (let [p (the (Small (+ 1 2) i32) (zeroed))] \ + (length (.items p))))"; + accepts "two literal fields meet at the wider type" + "(defstruct Pair [a $t b $t]) \ + (defn f [] f64 (let [p (Pair 1 2.5)] (+ (.a p) (.b p))))"; + rejects_check "a callee's predicate names the caller's variable with its $" + ~needle:"passes the type variable $t, which nothing here declares ordered?" + "(defn f [s [$t]] () (sort s))"; + accepts "a defonce of a generic struct's copy" + "(defstruct Pair [a $t b $t]) (defonce g (Pair i32)) \ + (defn main [] i32 (.a g))"; (* ── The builtin table against the arms it describes ────────────── [Check.builtins] is what the editor's C-c C-v and M-. read for a name no diff --git a/test/test_sanitize.ml b/test/test_sanitize.ml index d910dd0a..422dc8aa 100644 --- a/test/test_sanitize.ml +++ b/test/test_sanitize.ml @@ -376,13 +376,8 @@ let dyn_sweep () = part that carries the weight; the run is what says the constructor the fix introduced actually calls both of the things it replaced. - Not covered, and worth naming rather than leaving to be discovered the way - this bug was: a program driven by [flan dev] under ASan. The daemon builds - its host through its own path and the CLI has no [--sanitize] to pass it, - so that one wants a flag and a way through [Dev.serve]. See TODO.org, "A - program driven by a real flan dev daemon under a sanitizer". The faulting - dev build, which was on that list too, is covered now — see - [dev_segv] below. *) + A program driven by a real [flan dev] session is [dev_session] below, and + the faulting dev build is [dev_segv]. *) let dev_corpus = [ (* The only [dev-*] program with no agent import: it prints and returns. Here because it is the one program in the tree written for a dev @@ -474,6 +469,93 @@ let dev_segv () = prevent\n%s" text; (try Sys.remove exe with Sys_error _ -> ()) +(* A program driven by a real [flan dev --sanitize] session: the host and the + runtime under ASan and UBSan, the modules the session sends built as + always (llc and ld, not instrumented). dev-break stops on its first frame, + so the session starts at a break; it is resumed, [step] is redefined three + times with an expression evaluated after each, an expression is evaluated + into a second break and resumed out of it, and the session is closed. The + daemon's own output is the program's stderr, so a report anywhere in the + session lands in it. *) +let dev_session () = + let flan = "../bin/main.exe" in + let sock = Filename.concat scratch "flan-san-dev.sock" in + let log = Filename.concat scratch "flan-san-dev.log" in + let src = "programs/dev-break.flan" in + (try Sys.remove sock with Sys_error _ -> ()); + let fd = Unix.openfile log [ Unix.O_WRONLY; Unix.O_CREAT; Unix.O_TRUNC ] 0o600 in + let env = + Array.append (Unix.environment ()) + [| "ASAN_OPTIONS=detect_leaks=0"; "UBSAN_OPTIONS=print_stacktrace=1" |] + in + let pid = + Unix.create_process_env flan + [| flan; "dev"; src; "-s"; sock; "--sanitize" |] + env Unix.stdin fd fd + in + Unix.close fd; + let said () = In_channel.with_open_bin log In_channel.input_all in + if not (Test_support.listening ~ms:180000 ~pid sock) then begin + fail "dev session: flan dev --sanitize %s\n%s" !Test_support.listen_why + (said ()); + (try Unix.kill pid Sys.sigkill with Unix.Unix_error _ -> ()) + end + else begin + let c = Test_support.connect sock in + let ask q = Wire.parse (Wire.send c q; Wire.recv c) in + let field r k = Option.value ~default:"" (Wire.string_field r k) in + let stopped () = + match Wire.field (ask "(:op \"describe\")") "stopped" with + | Some { Form.v = Form.Sym "t"; _ } -> true + | _ -> false + in + let expect what r = + if field r "status" <> "ok" then + fail "dev session: %s: %s" what (field r "message") + in + let f = Printf.sprintf ":file %S" src in + if not (Test_support.await ~ms:30000 stopped) then + fail "dev session: the program never reached its first break" + else begin + expect "retry" (ask "(:op \"restart\" :name \"retry\")"); + if not (Test_support.await ~ms:10000 (fun () -> not (stopped ()))) then + fail "dev session: the program did not resume"; + for i = 1 to 3 do + expect "a redefinition" + (ask + (Printf.sprintf + "(:op \"eval\" :code \"(defn step [] i64 (set ticks (+ ticks \ + %d)) ticks)\" %s)" (100 * i) f)); + expect "an expression" + (ask (Printf.sprintf "(:op \"eval-expr\" :code \"(+ ticks 1)\" %s)" f)) + done; + let r = ask (Printf.sprintf "(:op \"eval-expr\" :code \"(divide 1 0)\" %s)" f) in + if not (contains (field r "condition") "ArithError") then + fail "dev session: (divide 1 0) did not stop on ArithError: %s" + (field r "message"); + expect "use-zero" (ask "(:op \"restart\" :name \"use-zero\")"); + if not (Test_support.await ~ms:10000 (fun () -> not (stopped ()))) then + fail "dev session: the program did not resume from the second break"; + expect "an expression after both breaks" + (ask (Printf.sprintf "(:op \"eval-expr\" :code \"(+ 1 2)\" %s)" f)) + end; + (try ignore (ask "(:op \"close\")") with _ -> ()); + (try Unix.close c with Unix.Unix_error _ -> ()); + if not + (Test_support.await ~ms:30000 (fun () -> + match Unix.waitpid [ Unix.WNOHANG ] pid with + | 0, _ -> false + | _ -> true)) + then begin + fail "dev session: the daemon did not end on close"; + (try Unix.kill pid Sys.sigkill with Unix.Unix_error _ -> ()); + (try ignore (Unix.waitpid [] pid) with Unix.Unix_error _ -> ()) + end; + if reported (said ()) then + fail "dev session: sanitizer report\n%s" (said ()) + end; + List.iter (fun f -> try Sys.remove f with Sys_error _ -> ()) [ sock; log ] + (* The positive controls, which are the only evidence that a clean sweep means anything. Both are written here rather than kept in test/programs because neither is a program anybody should build: one reads off the end of an @@ -600,6 +682,7 @@ let () = dyn_sweep (); dev_sweep (); dev_segv (); + dev_session (); unchecked_controls (); if !failures = 0 then print_endline "sanitizer sweep: clean" else Printf.printf "%d sanitizer failure(s)\n" !failures; diff --git a/test/test_session.ml b/test/test_session.ml index 5af415c9..241a5ef7 100644 --- a/test/test_session.ml +++ b/test/test_session.ml @@ -64,6 +64,19 @@ let () = fail "%s left a caller behind that nothing has" name | exception Loc.Error { Loc.dmsg = m; _ } -> fail "%s was refused: %s" name m in + (* A session's defn named as a prelude macro shadows it for a later form + sent alone, as the same defn does in a file. *) + (let t, _ = Session.create ~file:"programs/reload.flan" () in + match + ignore (Session.eval t "(defn clamp [x i64] i64 (+ x 1))"); + Session.eval t "(defn clamped [] i64 (clamp 4))" + with + | c -> + if not (List.mem "clamped" c.Session.fns) then + fail "a call to a session's clamp installed %s" + (String.concat " " c.Session.fns) + | exception Loc.Error { Loc.dmsg = m; _ } -> + fail "a call to a session's clamp was expanded as the macro: %s" m); installs "a changed parameter type" "(defn outer [x i64] i64 (bump))"; installs "a changed return type" "(defn outer [] i32 (i32 (bump)))"; installs "a changed arity" "(defn outer [a i64 b i64] i64 (bump))"; @@ -354,6 +367,76 @@ let () = | exception Loc.Error { Loc.dmsg = m; _ } -> fail "the session was poisoned by a bad expression: %s" m); + (* A generic struct's copy first named by an expression typed at the + session: the module built for it has to lay the copy out, and the + session keeps it, as it keeps a generic function's copy. *) + (let gt, _ = Session.create ~file:"programs/reload.flan" () in + (match Session.eval gt "(defstruct Pair [a $t b $t])" with + | _ -> () + | exception Loc.Error { Loc.dmsg = m; _ } -> + fail "a generic struct was refused at the session: %s" m); + match Session.eval_expr gt "(println (.b (Pair 7 8)))" with + | e -> + if not (has e.Session.ir "%\"Pair-i32\" = type") then + fail "the expression's module did not carry the struct copy"; + if not + (List.exists + (fun (s : Tast.structure) -> String.equal s.Tast.sname "Pair-i32") + gt.Session.program.Tast.structs) + then fail "the session did not keep the struct copy an expression made" + | exception Loc.Error { Loc.dmsg = m; _ } -> + fail "an expression building a generic struct was refused: %s" m); + + (* And the same for the other two modules the break loop builds out of + typed-in values: a store into a frame slot, and a restart's arguments. + A copy first named in one of them is laid out there and kept. *) + (let keeps t what = + List.exists + (fun (s : Tast.structure) -> String.equal s.Tast.sname what) + t.Session.program.Tast.structs + in + let lays_out (c : Session.change) what = + has c.Session.ir ("%\"" ^ what ^ "\" = type") + in + let st, _ = Session.create ~file:"programs/reload.flan" () in + (match Session.eval st "(defstruct Pair [a $t b $t])" with + | _ -> () + | exception Loc.Error { Loc.dmsg = m; _ } -> fail "Pair: %s" m); + (match Session.eval st "(defn holder [] i64 (let [x (the i64 0)] x))" with + | _ -> () + | exception Loc.Error { Loc.dmsg = m; _ } -> fail "holder: %s" m); + let fn = + List.find (fun (f : Tast.fn) -> f.Tast.name = "holder") + st.Session.program.Tast.fns + in + let slot = + let r = ref (-1) in + Array.iteri (fun i n -> if n = Some "x" then r := i) fn.Tast.snames; + !r + in + (match + Session.write_slot st ~frame:0 ~fn ~slot ~path:[] + ~edits:[ ([], "(.a (Pair (the i64 5) 6))") ] + with + | Ok (c, _, _) -> + if not (lays_out c "Pair-i64") then + fail "a store's module did not carry the struct copy its value made"; + if not (keeps st "Pair-i64") then + fail "the session did not keep the struct copy a store made" + | Error why -> fail "a store building a generic struct was refused: %s" why + | exception Loc.Error { Loc.dmsg = m; _ } -> + fail "a store building a generic struct was refused: %s" m); + match + Session.arm_restart st ~index:0 ~params:[ Types.Int Types.U16 ] + ~codes:[ "(.b (Pair (the u16 5) 6))" ] + with + | Ok (c, _) -> + if not (lays_out c "Pair-u16") then + fail "a restart's module did not carry the struct copy its argument made" + | Error why -> fail "a restart building a generic struct was refused: %s" why + | exception Loc.Error { Loc.dmsg = m; _ } -> + fail "a restart building a generic struct was refused: %s" m); + (* The other half of "a refusal costs nothing", and the half that used to be missing: a form can check and *then* fail, in the build or at the agent, and the session that already accepted it has no way to hear about it @@ -1315,17 +1398,25 @@ let () = if has c.Session.ir "@flan_reload_transient" then fail "a module that publishes a body claimed to be unloadable"; - (* And a third condition, about data rather than text. A string literal lives - in the evaluating module's own image, and an expression may store one - anywhere: [(set msg "x")] on a string global would leave that global - pointing into a mapping the agent then drops — and since the next thunk can - be mapped at the same address, the result is silent garbage rather than a - fault. A module carrying any string constant keeps its mapping. *) + (* And a third condition, about data rather than text. An expression may + store a string literal anywhere — [(set msg "x")] on a string global — so + a literal's value is a copy [flan_dev_literal] keeps for the process, and + nothing is left pointing into the module. A string constant the module + does hand out still keeps its mapping: a condition's name, which a handler + may carry away. *) let str = Session.eval_expr t "(println \"tuned\")" in - if not (has str.Session.ir ".str.0") then - fail "the fixture stopped carrying a string constant, so it proves nothing"; - if has str.Session.ir "@flan_reload_transient" then - fail "an expression holding a string claimed to be unloadable"; + if not (has str.Session.ir "@flan_dev_literal(ptr") then + fail "an expression's string literal is not a kept copy"; + if has str.Session.ir ".str." then + fail "an expression's string literal is still a constant of its module"; + if not (has str.Session.ir "@flan_reload_transient") then + fail "an expression whose only string is a literal kept its mapping"; + let held = + Session.eval_expr t + "(restart-case (+ 1 2) (use-zero [] :report \"Answer 0\" 0))" + in + if has held.Session.ir "@flan_reload_transient" then + fail "an expression establishing a restart claimed to be unloadable"; (* ── Generics in the dev loop ───────────────────────────────────────── A generic [defn] produces no [Tast.fn] of its own — only its copies do — @@ -1523,7 +1614,7 @@ let () = (* And the slot names, in the packed form the runtime splits — which is what says the call carries *this* class's new list and not some other module's leftovers. *) - if not (has c.Session.ir "c\"x\\0Ay\\0Az\\00\"") then + if not (has c.Session.ir "c\"x\\0Ay\\0Az\"") then fail "the registration did not carry the new slot list" | exception Loc.Error { Loc.dmsg = m; _ } -> fail "adding a slot to a class was refused: %s" m); @@ -1556,7 +1647,7 @@ let () = | c -> if not (has c.Session.ir "call void @flan_dyn_class_def") then fail "an unchanged class definition registered nothing"; - if not (has c.Session.ir "c\"x\\0Ay\\00\"") then + if not (has c.Session.ir "c\"x\\0Ay\"") then fail "an unchanged class registered some other slot list" | exception Loc.Error { Loc.dmsg = m; _ } -> fail "re-evaluating an unchanged class was refused: %s" m); @@ -1620,7 +1711,7 @@ let () = ignore (Session.eval t "(defn origin [] dyn (point 0 0))"); match Session.eval t "(defclass point [x i64 y])" with | c -> - if not (has c.Session.ir "c\"x i64\\0Ay\\00\"") then + if not (has c.Session.ir "c\"x i64\\0Ay\"") then fail "a slot's new type did not reach the registration" | exception Loc.Error { Loc.dmsg = m; _ } -> fail "a slot's type changed under a compiled caller was refused: %s" m); @@ -1764,4 +1855,60 @@ let () = | _ -> fail "a package's bare name resolved from the program's own file" | exception Loc.Error _ -> ()); + (* ── Every error in the form sent ─────────────────────────────────── + A refused subexpression stands as a value that fits anywhere, so the + check goes on past it: three bad expressions are three errors, one three + levels down is still found, and what a failure causes is not reported. *) + (let errors src = + let t, _ = Session.create ~file:"programs/reload.flan" () in + match Session.eval t src with + | _ -> fail "a form with errors was accepted: %s" src; [] + | exception Loc.Error d -> [ d ] + | exception Loc.Errors ds -> ds + in + let msgs ds = String.concat " | " (List.map (fun (d : Loc.diag) -> d.Loc.dmsg) ds) in + let three = + errors + "(defn three [] i64 (println (+ 1 \"a\")) (println (nope 2)) (+ 3 \"c\"))" + in + if List.length three <> 3 then + fail "three bad expressions gave %d errors: %s" (List.length three) (msgs three); + let deep = + errors + "(defn deep [] i64 (+ 1 \"a\") (if true (let [x (do (println (nope 2)) 1)] x) 0))" + in + if List.length deep <> 2 || not (has (msgs deep) "nope") then + fail "an error three levels down was not reported: %s" (msgs deep); + (* The failed call poisons the let's [x]; the field read of it and the sum + it flows into are consequences, and are not said. *) + let caused = + errors "(defn caused [] i64 (let [x (nope 1)] (+ (.foo x) (+ x 1))))" + in + if List.length caused <> 1 || not (has (msgs caused) "nope") then + fail "a failure's consequences were reported: %s" (msgs caused); + (* A local bound to a refused initialiser and then called is the same + consequence: no "unknown function p". *) + let called = errors "(defn called [] i64 (let [p (nope 1)] (p 3)))" in + if List.length called <> 1 then + fail "calling a local bound to a failure was reported: %s" (msgs called); + (* A call refused for its argument count still has its arguments checked. *) + let arity = + errors "(defn arity [] i64 (bump (nope2) 7 8))" + in + if List.length arity <> 2 || not (has (msgs arity) "nope2") then + fail "an error inside a miscounted call was not reported: %s" (msgs arity); + (* And the whole-file path: fn-no-type.flan has one mistake, reported once. *) + (match Front.checked ~all:true "programs/fn-no-type.flan" with + | _ -> fail "fn-no-type.flan checked" + | exception Loc.Error _ -> () + | exception Loc.Errors ds -> + if List.length ds <> 1 then + fail "fn-no-type.flan gave %d errors: %s" (List.length ds) (msgs ds)); + (* One error is the [Loc.Error] every caller of one form expects. *) + let t, _ = Session.create ~file:"programs/reload.flan" () in + (match Session.eval t "(defn one [] i64 (nope 1))" with + | _ -> fail "an unknown function was accepted" + | exception Loc.Error _ -> () + | exception Loc.Errors _ -> fail "one error came as a list")); + Test_support.report ~label:"session" () diff --git a/test/test_syntax.ml b/test/test_syntax.ml index e9c7fe03..928be6a2 100644 --- a/test/test_syntax.ml +++ b/test/test_syntax.ml @@ -354,6 +354,9 @@ let () = reads "elif" "if a\n 1\nelif b\n 2\nelse\n 3" "(cond a 1 b 2 :else 3)"; reads "one-line if" "x = if a then 1 else 2" "(set x (if a 1 2))"; reads "assignment ops" "a[i] += 1" "(set (at a i) (+ (at a i) 1))"; + (* A place with a call in it is evaluated once: it reads as update. *) + reads "assignment op over a call's place" "a[next()] += 1" + "(update (at a (next)) + 1)"; reads "for" "for :outer i in range(1, n)\n f(i)" "(dotimes :outer [i 1 n] (f i))"; reads "unit statement" "restart-case\n f()\nrestart continue()\n ()" "(restart-case (f) (continue [] (do)))"; @@ -413,6 +416,8 @@ let () = | exception e -> fail "%s: %s" name (diag_text e) in prints "compound assignment" "(defn f [] () (set x (+ x 1)))" " x += 1"; + prints "compound update" "(defn f [] () (update (at a (next)) + 1))" + " a[next()] += 1"; prints "arm statements" "(defn f [] () (match s 1 (break) _ (return 2)))" "1 -> break\n _ -> return 2"; prints "then and else statements" "(defn f [] () (if c (return 1) (set x 2)))" diff --git a/vendor/agent/flan_agent.c b/vendor/agent/flan_agent.c index 47aae148..dda48ddb 100644 --- a/vendor/agent/flan_agent.c +++ b/vendor/agent/flan_agent.c @@ -214,8 +214,19 @@ typedef struct { void *handle; int stopped_only; int32_t at_stop; + uint32_t call_id; /* its place among jobs with a call; 0 if none */ } job; +/* Which evaluated expression the result buffer holds. Every job with a call + * is numbered as the listener queues it, and a call that returns records its + * number, so a daemon waiting for its own expression's value is not answered + * by an earlier expression that a restart resumed and that published after + * the new one was sent. The highest wins: an expression run inside another's + * break returns first, and the outer one only resumes on a later request. + * The [calls] verb answers both counts. */ +static _Atomic uint32_t calls_queued; +static _Atomic uint32_t calls_valued; + /* Said once, in one place, and shipped to the daemon over [refusals] rather * than written down again at the other end. A refusal is a sentence naming * what actually happened, and the thing that actually happened is not "the @@ -437,6 +448,15 @@ static const uint8_t abandon_report[] = * saved and restored around the call like [eval_boundary]. */ static sigjmp_buf *eval_escape; +/* Whether the game thread is inside an evaluated thunk's call, at any depth, + * rather than in the program's own code. A break records it, and it is what + * says whose break that is: a game loop that signals on its own while an + * evaluation is in flight stops exactly as a thunk would, and the stop + * counter cannot tell the two apart. Not [eval_boundary], which a class + * migration clears inside a thunk, nor [frame_floor], which it sets outside + * one. Game thread only, saved and restored around the call. */ +static int in_thunk; + /* What the chains looked like when the evaluation was called, weak for the * reason the frame walk below is: the runtime is linked into every program * that links this, but not every build carries the dev and dyn halves. */ @@ -505,6 +525,7 @@ static int migrate_call(void *fn, uint64_t instance, uint64_t added, void flan_agent_run_reset(void) { eval_boundary = NULL; eval_escape = NULL; + in_thunk = 0; restart_floor = 0; frame_floor = -1; } @@ -567,6 +588,7 @@ static _Atomic int aborting; typedef struct { int32_t gen; /* never reused, never 0 */ + int32_t in_eval; /* stopped inside a thunk */ /* Whether *any* restart on this list can be taken, which is a property of * the break and not of the restarts. [reachable] answers a different * question — that one is per restart, and it is about the thunk boundary. @@ -773,6 +795,7 @@ static int snap_push(int resumable, void *cond) { snapshot *s = &snaps[d]; int32_t n = flan_restart_count(); s->gen = ++snap_gen; + s->in_eval = in_thunk; s->resumable = resumable; s->cond = cond; s->sitelen = 0; @@ -1310,6 +1333,7 @@ int32_t flan_agent_poll(void) { * signal handler, and the jump leaves the handler. */ sigjmp_buf escape; sigjmp_buf *oescape = eval_escape; + int othunk = in_thunk; void *mh = NULL, *mr = NULL, *mf = NULL; int32_t md = 0; int64_t mroots = 0; @@ -1318,9 +1342,12 @@ int32_t flan_agent_poll(void) { if (flan_dyn_root_mark) mroots = flan_dyn_root_mark(); uint64_t mctx[2] = { 0, 0 }; if (flan_context_save) flan_context_save(mctx); + in_thunk = 1; if (sigsetjmp(escape, 1) == 0) { eval_escape = &escape; j.call(); + if (j.call_id > atomic_load(&calls_valued)) + atomic_store(&calls_valued, j.call_id); } else { if (flan_condition_stacks_restore) flan_condition_stacks_restore(mh, mr, md); if (flan_dev_frames_restore) flan_dev_frames_restore(mf); @@ -1328,6 +1355,7 @@ int32_t flan_agent_poll(void) { if (flan_context_load) flan_context_load(mctx); } eval_escape = oescape; + in_thunk = othunk; /* Popped whichever way the thunk left — returning with a value, or * unwinding past this frame because someone abandoned it. */ flan_restart_pop_c(eval_boundary); @@ -1903,10 +1931,23 @@ static void handle_line(char *line, sink *o) { * of those have readers in flight and a reply format is a thing two ends * agree on. Answered while running as well, for [status]'s reason: an * editor polls this without knowing the state already. */ + /* After the number, whose code stopped: "eval" when the thread was inside + * an evaluated thunk, "program" when it was in the program's own code. */ + if (strcmp(line, "calls") == 0) { + char hdr[48]; + int k = snprintf(hdr, sizeof hdr, "%u %u\n", + (unsigned)atomic_load(&calls_queued), + (unsigned)atomic_load(&calls_valued)); + if (k > 0) emit(o, hdr, (size_t)k); + return; + } if (strcmp(line, "stop") == 0) { snapshot *s = (atomic_load(&depth) > 0) ? snap_top() : NULL; char hdr[32]; - int k = snprintf(hdr, sizeof hdr, "%d\n", s == NULL ? 0 : s->gen); + int k = s == NULL + ? snprintf(hdr, sizeof hdr, "0\n") + : snprintf(hdr, sizeof hdr, "%d %s\n", s->gen, + s->in_eval ? "eval" : "program"); if (k > 0) emit(o, hdr, (size_t)k); return; } @@ -2179,7 +2220,9 @@ static void handle_line(char *line, sink *o) { * is the failure being fixed. */ if (!publish((job){ .install = f, .call = c, .handle = transient == NULL ? NULL : h, - .stopped_only = stopped_only, .at_stop = at_stop })) + .stopped_only = stopped_only, .at_stop = at_stop, + .call_id = c == NULL ? 0 + : atomic_fetch_add(&calls_queued, 1) + 1 })) fprintf(stderr, "flan: reload queue full after it was checked\n"); return; } @@ -2459,17 +2502,49 @@ failed: return -1; } +/* The daemon's socket for this process, or NULL when there is none. + * + * FLAN_AGENT_SOCKET alone is not enough, because an environment is inherited: + * a shell started from inside a [flan dev] program, or anything that program + * starts, carries it too, and binding unlinks the path first, so such a + * process would take the session's socket from the program it belongs to. So + * the daemon also names the process it launched, in FLAN_AGENT_OWNER, and the + * path is honoured only there: the owner is this process in a merged build, + * where the launcher execs into the program, and this process's parent under + * --two-process, where the daemon started it. */ +static const char *daemon_socket(void) { + const char *env = getenv("FLAN_AGENT_SOCKET"); + const char *own = getenv("FLAN_AGENT_OWNER"); + char *end; + long pid; + if (env == NULL || env[0] == '\0' || own == NULL || own[0] == '\0') + return NULL; + pid = strtol(own, &end, 10); + if (end == own || *end != '\0' || pid <= 0) return NULL; + if (pid == (long)getpid()) return env; + /* The parent only under --two-process, which is the one shape that sets + * FLAN_DEV_PARENT, and to the same pid. In a merged build the owner is the + * program itself, so a process it starts has the owner as its parent and + * must not take the socket. */ + { + const char *par = getenv("FLAN_DEV_PARENT"); + if (par != NULL && strcmp(par, own) == 0 && pid == (long)getppid()) + return env; + } + return NULL; +} + /* [path] is a Flan string: ptr and len, not NUL-terminated. * - * FLAN_AGENT_SOCKET overrides it. A program's source has to name some path, - * and the daemon that launches the program is the one that knows where it + * The daemon's socket overrides it (see [daemon_socket]). A program's source + * has to name some path, and the daemon that launches the program is the one that knows where it * wants to talk to it — without the override the daemon would have to guess, * and guessing wrong fails silently: everything compiles, the module is built, * and nothing ever receives it. */ int32_t flan_agent_start(const uint8_t *path, int64_t len) { char buf[sizeof(((struct sockaddr_un *)0)->sun_path)]; - const char *env = getenv("FLAN_AGENT_SOCKET"); - if (env != NULL && env[0] != '\0') return start_on(env) < 0 ? -1 : 0; + const char *env = daemon_socket(); + if (env != NULL) return start_on(env) < 0 ? -1 : 0; if (len <= 0 || (size_t)len >= sizeof buf) return -1; memcpy(buf, path, (size_t)len); buf[len] = '\0'; @@ -2493,8 +2568,8 @@ int32_t flan_agent_start_auto(void) { char path[sizeof(((struct sockaddr_un *)0)->sun_path)]; struct timespec ts; int32_t r; - const char *env = getenv("FLAN_AGENT_SOCKET"); - if (env != NULL && env[0] != '\0') return start_on(env) < 0 ? -1 : 0; + const char *env = daemon_socket(); + if (env != NULL) return start_on(env) < 0 ? -1 : 0; if (clock_gettime(CLOCK_REALTIME, &ts) != 0) ts.tv_nsec = 0; snprintf(path, sizeof path, "/tmp/flan-agent-%ld-%08lx.sock", (long)getpid(), (unsigned long)(ts.tv_nsec & 0xffffffffL)); @@ -2511,11 +2586,11 @@ int32_t flan_agent_start_auto(void) { /* And the call itself, gone. A program under [flan dev] that imports this * package gets the listener before main, without asking. * - * FLAN_AGENT_SOCKET is the whole condition, and it is the right one: the - * daemon sets it in both shapes — before the fork in --two-process, before the - * exec in the merged build — and nothing else on a machine sets it. So an - * ordinary run of an ordinary program falls straight through here and this - * costs it one getenv. (Not FLAN_DEV_PARENT, which is deliberately unset in + * [daemon_socket] is the condition: the daemon sets both of its variables in + * both shapes — before the fork in --two-process, before the exec in the + * merged build — so an ordinary run of an ordinary program falls straight + * through here, and so does a process that only inherited them. (Not + * FLAN_DEV_PARENT, which is deliberately unset in * the merged build; gating on it would quietly skip half the daemon.) * * WHAT THIS DOES NOT REACH, because it is a fact about linking rather than a @@ -2540,8 +2615,8 @@ int32_t flan_agent_start_auto(void) { * cannot, in either shape — it has an editor to hear from first, and a module * to compile after that. */ __attribute__((constructor)) static void auto_start(void) { - const char *env = getenv("FLAN_AGENT_SOCKET"); - if (env == NULL || env[0] == '\0') return; + const char *env = daemon_socket(); + if (env == NULL) return; /* The answer is dropped because there is nobody to give it to: this is ELF * init, before main, before the program has decided anything. What matters * is that a failure here is not final — [start_on] gives [started] back, so diff --git a/web/index.html b/web/index.html index 7d1df1ee..ea18a0de 100644 --- a/web/index.html +++ b/web/index.html @@ -842,8 +842,10 @@ is allocated. (bytes-view s) is the string's own storage seen as a [const u8] and costs nothing; it aliases the string, and a store through it is a compile error. (bytes s) and (bytes s allocator) make a writable copy through the allocator — never a -hidden malloc, which is the rule every allocating operation follows. The -example above wants a view and takes one.

+hidden malloc, which is the rule every allocating operation follows. +(free b) hands the copy back to the current allocator and +(free b allocator) to the one named. The example above wants a view and +takes one.

An enum is an i32 at run time and its own type in the checker. A keyword at a call site resolves against the parameter's enum type at compile time, so a @@ -1275,13 +1277,14 @@ $t)} at the head of the body, or take the operation as a parameter — a

What makes that liveable is a where clause, written as a Clojure-style map at the head of the body — {:where (ordered? $t)}, or a vector when there is more than one: {:where [(ordered? $t) (hashable? $u)]}. There -are five predicates, and each gates builtins the compiler already has:

+are six predicates, and each gates builtins the compiler already has:

+ @@ -1290,7 +1293,8 @@ are five predicates, and each gates builtins the compiler already has:

They entail each other in one direction, so one clause usually does: integer? gives numeric?, numeric? gives -ordered?, and ordered? gives equal?. A +ordered?, and ordered? gives equal?; +enum? gives ordered? too. A sort that compares its elements declares ordered? and nothing else, and the prelude's abs declares integer? alone — the bound is what keeps its integer body away from the floats, whose

PredicateWhat it admits
integer?bit-and bit-or bit-xor << >> — every integer type, no float
numeric?+ - * / %, and a cast (t x)
enum?a cast to a number, (i32 x) — every enum type
ordered?< <= > >= min max
equal?= and !=
hashable?the variable as a Map key — (map-new t V), get, put, has-key?