From 680b8e7e595e59f10c973c6045017de05a19f290 Mon Sep 17 00:00:00 2001 From: Joseph Ferano Date: Fri, 25 Sep 2026 15:13:12 +0700 Subject: [PATCH 01/42] A refusal inside a generic copy names each call that asked for it, a refused generic body is reported once, and a type variable prints with its $ --- TODO.org | 15 ----------- lib/check.ml | 57 ++++++++++++++++++++++++++++++++++------- lib/dev.ml | 8 +++--- lib/types.ml | 2 +- test/test_acceptance.ml | 6 ++--- test/test_flan.ml | 39 +++++++++++++++++++++++++--- 6 files changed, 90 insertions(+), 37 deletions(-) diff --git a/TODO.org b/TODO.org index 899c9b6e..0a5e280d 100644 --- a/TODO.org +++ b/TODO.org @@ -767,12 +767,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 @@ -1030,15 +1024,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"; diff --git a/lib/check.ml b/lib/check.ml index ee0c4daf..0c03ca82 100644 --- a/lib/check.ml +++ b/lib/check.ml @@ -192,6 +192,12 @@ 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; (* 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 @@ -240,6 +246,7 @@ let new_env () = { subst = []; tvpreds = []; chain = []; + refused_generics = Hashtbl.create 4; in_field = false; classes = Hashtbl.create 8; tracks = Hashtbl.create 16; @@ -2157,7 +2164,7 @@ 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) @@ -2185,6 +2192,9 @@ let rec mangle_ty (t : Types.t) = | 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 | t -> Types.to_string t (* ── The runaway instantiation, refused by name rather than by depth ──── @@ -4099,14 +4109,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)" @@ -6548,9 +6558,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) @@ -11284,11 +11292,39 @@ and instantiate env loc gname vars subst cparams cret = env.subst <- saved_subst; env.tyvars <- saved_vars; env.tvpreds <- saved_preds; env.chain <- saved_chain 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 | 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 e = + match e with + | Loc.Error d when d.Loc.dloc <> loc -> + let at = + String.concat ", " + (List.map + (fun v -> Printf.sprintf "$%s = %s" v + (Types.to_string (List.assoc v subst))) + vars) + in + 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. *) @@ -13933,9 +13969,12 @@ 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 () -> Some (check_generic env fn))) + with + | None -> Hashtbl.replace env.refused_generics fn.Ast.name () + | Some _ -> ()) | _ -> ()) decls; let globals = diff --git a/lib/dev.ml b/lib/dev.ml index 7f052f25..8c54e3e7 100644 --- a/lib/dev.ml +++ b/lib/dev.ml @@ -669,14 +669,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)) diff --git a/lib/types.ml b/lib/types.ml index 3513621f..6e2bb57d 100644 --- a/lib/types.ml +++ b/lib/types.ml @@ -231,7 +231,7 @@ 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 | Dyn -> "dyn" let is_numeric = function Int _ | Float _ -> true | _ -> false diff --git a/test/test_acceptance.ml b/test/test_acceptance.ml index a0fe1a0f..4f08c8bf 100644 --- a/test/test_acceptance.ml +++ b/test/test_acceptance.ml @@ -3608,7 +3608,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" @@ -4680,10 +4680,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; diff --git a/test/test_flan.ml b/test/test_flan.ml index 4d0f57f7..d306b1d1 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. *) @@ -5988,6 +5988,37 @@ 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" ])); + (* 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 +6077,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 +6105,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? From 8dc90416d4f5da5dd42cfd35d13ba388f03b2a0e Mon Sep 17 00:00:00 2001 From: Joseph Ferano Date: Fri, 25 Sep 2026 15:14:23 +0700 Subject: [PATCH 02/42] The daemon's buffer draws errors, warnings and notes in compilation's faces and the program's own output in a face of its own --- TODO.org | 6 ------ emacs/flan.el | 30 +++++++++++++++++++++++++++--- emacs/test-flan.el | 31 +++++++++++++++++++++++++++++++ 3 files changed, 58 insertions(+), 9 deletions(-) diff --git a/TODO.org b/TODO.org index 899c9b6e..e04e66a1 100644 --- a/TODO.org +++ b/TODO.org @@ -2079,12 +2079,6 @@ per-phase; making it per-form would need a resync point inside a body. 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/emacs/flan.el b/emacs/flan.el index 92e42a89..36f78e31 100644 --- a/emacs/flan.el +++ b/emacs/flan.el @@ -412,6 +412,25 @@ 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) + (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 +442,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 +918,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 diff --git a/emacs/test-flan.el b/emacs/test-flan.el index 74853a05..5fa5cd5d 100644 --- a/emacs/test-flan.el +++ b/emacs/test-flan.el @@ -533,6 +533,37 @@ 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\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 + "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. From d5fc3aa657f47ce43902d4d3a35573f7bd47e7e5 Mon Sep 17 00:00:00 2001 From: Joseph Ferano Date: Fri, 25 Sep 2026 15:18:55 +0700 Subject: [PATCH 03/42] The agent binds the daemon's socket only in the process the daemon launched, named by FLAN_AGENT_OWNER --- README.md | 6 +-- TODO.org | 7 ---- lib/dev.ml | 7 ++++ test/test_agent.ml | 78 ++++++++++++++++++++++++++++++++++++--- vendor/agent/flan_agent.c | 49 +++++++++++++++++------- 5 files changed, 119 insertions(+), 28 deletions(-) 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 899c9b6e..aa50db50 100644 --- a/TODO.org +++ b/TODO.org @@ -1637,13 +1637,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 diff --git a/lib/dev.ml b/lib/dev.ml index 7f052f25..ccbe8084 100644 --- a/lib/dev.ml +++ b/lib/dev.ml @@ -5251,6 +5251,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 @@ -6264,6 +6268,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; diff --git a/test/test_agent.ml b/test/test_agent.ml index def7521c..f4847b28 100644 --- a/test/test_agent.ml +++ b/test/test_agent.ml @@ -61,6 +61,13 @@ 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 = + [| "FLAN_AGENT_SOCKET=" ^ path; + "FLAN_AGENT_OWNER=" ^ string_of_int (Unix.getpid ()) |] + let () = match Sys.command "command -v clang > /dev/null 2>&1 && command -v llc > /dev/null 2>&1" with | 0 -> @@ -298,7 +305,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,8 +332,69 @@ 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 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=1" |] + 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 "a program with someone else's FLAN_AGENT_SOCKET announced no \ + socket of its own"; + (try Unix.kill spid Sys.sigkill with Unix.Unix_error _ -> ()) + | Some p -> + if p = stolen then fail "the inherited path was bound: %S" p; + if not (await (fun () -> Sys.file_exists p)) then + fail "nothing was bound at the announced %S" 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 "the program with an inherited variable never finished" + end); + (match In_channel.with_open_bin stolen In_channel.input_all with + | "the session's" -> () + | _ -> fail "the inherited FLAN_AGENT_SOCKET's file was replaced" + | exception Sys_error _ -> + fail "the inherited FLAN_AGENT_SOCKET's file was removed"); + List.iter (fun f -> try Sys.remove f with Sys_error _ -> ()) - [ aexe; aso; aout; aerr; bad ]; + [ aexe; aso; aout; aerr; bad; stolen; serr; tmp "stolen.out" ]; (* ── No (agent/start) at all ────────────────────────────────────── *) @@ -359,7 +427,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 +480,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 +821,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/vendor/agent/flan_agent.c b/vendor/agent/flan_agent.c index 47aae148..efe49f02 100644 --- a/vendor/agent/flan_agent.c +++ b/vendor/agent/flan_agent.c @@ -2459,17 +2459,40 @@ 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() && pid != (long)getppid()) return NULL; + return env; +} + /* [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 +2516,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 +2534,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 +2563,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 From 5b8c4a68fa64a7cebf6e532e62b1cbfc1a6b9ec1 Mon Sep 17 00:00:00 2001 From: Joseph Ferano Date: Fri, 25 Sep 2026 15:22:44 +0700 Subject: [PATCH 04/42] into refuses to copy elements that own storage as they stand, and names (map clone) where clone takes the element --- lib/check.ml | 106 +++++++++++++++++++++++++++++++-- lib/prelude.ml | 18 ++++++ test/programs/into-owning.flan | 22 +++++++ test/test_acceptance.ml | 5 ++ test/test_flan.ml | 28 +++++++++ 5 files changed, 175 insertions(+), 4 deletions(-) create mode 100644 test/programs/into-owning.flan diff --git a/lib/check.ml b/lib/check.ml index ee0c4daf..d2ef76b2 100644 --- a/lib/check.ml +++ b/lib/check.ml @@ -2429,6 +2429,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 @@ -9136,6 +9179,57 @@ and named_call ?(qualified = false) ctx ~want loc name args = fail loc "free takes an owning container — a Vec or a Map — 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" -> @@ -9171,9 +9265,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 @@ -9181,9 +9275,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 -> @@ -11708,6 +11802,10 @@ let builtins : (string * string * string) list = allocator's free-all or destroy. 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)", diff --git a/lib/prelude.ml b/lib/prelude.ml index 904da3c9..c69bf2ca 100644 --- a/lib/prelude.ml +++ b/lib/prelude.ml @@ -2371,6 +2371,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. @@ -2423,10 +2432,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/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/test_acceptance.ml b/test/test_acceptance.ml index a0fe1a0f..da83f4ca 100644 --- a/test/test_acceptance.ml +++ b/test/test_acceptance.ml @@ -613,6 +613,11 @@ 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. *) + 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 diff --git a/test/test_flan.ml b/test/test_flan.ml index 4d0f57f7..6d534420 100644 --- a/test/test_flan.ml +++ b/test/test_flan.ml @@ -3188,6 +3188,34 @@ 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"; accepts "clone on a slice, with and without an allocator" "(defn f [v [f64] a Allocator] i32 (+ (length (clone v)) (length (clone v a))))"; From 58d1e352258b03fe9d91c6eb7d42024506904d04 Mon Sep 17 00:00:00 2001 From: Joseph Ferano Date: Fri, 25 Sep 2026 15:16:56 +0700 Subject: [PATCH 05/42] A local of a package's type is named by its qualified type in the break buffer's listing and the inspector, pinned by a shape/Box local in dev-inspect.flan --- TODO.org | 6 ------ test/programs/dev-inspect.flan | 7 +++++-- test/test_dev.ml | 15 +++++++++++++++ 3 files changed, 20 insertions(+), 8 deletions(-) diff --git a/TODO.org b/TODO.org index 899c9b6e..306111cc 100644 --- a/TODO.org +++ b/TODO.org @@ -1693,12 +1693,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 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/test_dev.ml b/test/test_dev.ml index d5446668..7cf14617 100644 --- a/test/test_dev.ml +++ b/test/test_dev.ml @@ -2516,6 +2516,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. *) From c30f52c5a779928bdbff04b878ed5de896fa3f97 Mon Sep 17 00:00:00 2001 From: Joseph Ferano Date: Fri, 25 Sep 2026 15:25:09 +0700 Subject: [PATCH 06/42] A stop records whether it was inside an evaluated thunk, and an evaluation waits through a break the program's own code entered --- TODO.org | 8 ---- lib/dev.ml | 45 ++++++++++++++-------- test/programs/dev-own-break.flan | 22 +++++++++++ test/test_dev.ml | 65 ++++++++++++++++++++++++++++++++ vendor/agent/flan_agent.c | 22 ++++++++++- 5 files changed, 138 insertions(+), 24 deletions(-) create mode 100644 test/programs/dev-own-break.flan diff --git a/TODO.org b/TODO.org index aa50db50..bc1164ef 100644 --- a/TODO.org +++ b/TODO.org @@ -1584,14 +1584,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 diff --git a/lib/dev.ml b/lib/dev.ml index ccbe8084..5d9f3a17 100644 --- a/lib/dev.ml +++ b/lib/dev.ml @@ -268,10 +268,28 @@ 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) + +(* 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. @@ -1225,17 +1243,9 @@ 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 t.n <- t.n + 1; @@ -1323,12 +1333,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 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/test_dev.ml b/test/test_dev.ml index d5446668..dcbff377 100644 --- a/test/test_dev.ml +++ b/test/test_dev.ml @@ -8712,6 +8712,71 @@ let () = hook_block ~llvm:false; hook_block ~llvm:true; + (* ── 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 + 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/vendor/agent/flan_agent.c b/vendor/agent/flan_agent.c index efe49f02..5cc5c027 100644 --- a/vendor/agent/flan_agent.c +++ b/vendor/agent/flan_agent.c @@ -437,6 +437,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 +514,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 +577,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 +784,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 +1322,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,6 +1331,7 @@ 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(); @@ -1328,6 +1342,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 +1918,15 @@ 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, "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; } From b8c81d94ee41bbe2748759febdbc7a16f28ba26b Mon Sep 17 00:00:00 2001 From: Joseph Ferano Date: Fri, 25 Sep 2026 15:26:27 +0700 Subject: [PATCH 07/42] enum? admits exactly the enums, entails ordered? and equal?, and licenses a generic conversion from an enum to a number beside numeric? --- TODO.org | 8 ----- lib/check.ml | 53 +++++++++++++++++++++++---------- plan.org | 11 +++---- spec-memory.md | 12 ++++---- test/programs/enum-generic.flan | 28 +++++++++++++++++ test/test_acceptance.ml | 5 ++++ test/test_flan.ml | 26 ++++++++++++++-- web/index.html | 6 ++-- 8 files changed, 111 insertions(+), 38 deletions(-) create mode 100644 test/programs/enum-generic.flan diff --git a/TODO.org b/TODO.org index 306111cc..8dc501d0 100644 --- a/TODO.org +++ b/TODO.org @@ -680,14 +680,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 diff --git a/lib/check.ml b/lib/check.ml index d2ef76b2..4bb9018c 100644 --- a/lib/check.ml +++ b/lib/check.ml @@ -873,18 +873,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 +1029,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 +1042,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 @@ -7709,9 +7716,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) -> @@ -7727,10 +7741,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 @@ -10587,8 +10610,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 -> @@ -10619,8 +10642,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 diff --git a/plan.org b/plan.org index 060ad2dd..fec96e93 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/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/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/test_acceptance.ml b/test/test_acceptance.ml index da83f4ca..2a2ba22b 100644 --- a/test/test_acceptance.ml +++ b/test/test_acceptance.ml @@ -4171,6 +4171,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; diff --git a/test/test_flan.ml b/test/test_flan.ml index 6d534420..d4013662 100644 --- a/test/test_flan.ml +++ b/test/test_flan.ml @@ -6171,7 +6171,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" @@ -6182,9 +6183,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. *) diff --git a/web/index.html b/web/index.html index a4a686e5..c7bbe0c9 100644 --- a/web/index.html +++ b/web/index.html @@ -1275,13 +1275,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 +1291,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 From 8cc63ed9f6414fe57099cc48661af5550f7134bc Mon Sep 17 00:00:00 2001 From: Joseph Ferano Date: Fri, 25 Sep 2026 15:24:32 +0700 Subject: [PATCH 08/42] A place in update, ++ and -- evaluates each of its subexpressions once, and (update place f args ...) stores (f old args ...) back into it --- TODO.org | 15 -------- docs/BUILT.md | 2 +- lib/parse.ml | 67 +++++++++++++++++++++++++++++++++ lib/prelude.ml | 39 +++++++++++++------ spec-syntax.md | 2 +- test/programs/update-place.flan | 55 +++++++++++++++++++++++++++ test/test_acceptance.ml | 18 +++++++++ 7 files changed, 169 insertions(+), 29 deletions(-) create mode 100644 test/programs/update-place.flan diff --git a/TODO.org b/TODO.org index 8dc501d0..f395baa5 100644 --- a/TODO.org +++ b/TODO.org @@ -1959,21 +1959,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 diff --git a/docs/BUILT.md b/docs/BUILT.md index 2fc8b761..567337f6 100644 --- a/docs/BUILT.md +++ b/docs/BUILT.md @@ -3887,7 +3887,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 ...)`. diff --git a/lib/parse.ml b/lib/parse.ml index e5190994..88b824a5 100644 --- a/lib/parse.ml +++ b/lib/parse.ml @@ -449,6 +449,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 @@ -1252,6 +1260,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 | [] -> [] diff --git a/lib/prelude.ml b/lib/prelude.ml index c69bf2ca..8d201c41 100644 --- a/lib/prelude.ml +++ b/lib/prelude.ml @@ -2270,16 +2270,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) @@ -2293,12 +2289,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 ──────────────── ;; diff --git a/spec-syntax.md b/spec-syntax.md index 4800e773..77639572 100644 --- a/spec-syntax.md +++ b/spec-syntax.md @@ -142,7 +142,7 @@ Each item: the proposal, then the reason in one line. index, field). - **`==` 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. + `(update x + v)`, which evaluates the place once, as `++` does. - **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/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 2a2ba22b..d41fa573 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 @@ -4904,6 +4911,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" From f6ba1e6c4d9fe4987f144aef40a8b5a459bcebe2 Mon Sep 17 00:00:00 2001 From: Joseph Ferano Date: Fri, 25 Sep 2026 15:26:02 +0700 Subject: [PATCH 09/42] A CFn may sit in a struct field, a fixed array or a global, and a call through a null one signals NullCall on both backends --- TODO.org | 11 +++---- docs/BUILT.md | 5 +-- lib/check.ml | 19 ++++++++++-- lib/emit.ml | 19 ++++++++++++ lib/prelude.ml | 11 +++++++ lib/x86.ml | 23 ++++++++++++++ runtime/flan_rt.c | 45 +++++++++++++++++++++++++++ test/programs/fn-cfn-table.flan | 55 +++++++++++++++++++++++++++++++++ test/programs/fn-in-struct.flan | 6 ++-- test/test_acceptance.ml | 29 +++++++++++++++++ test/test_flan.ml | 17 ++++++++++ 11 files changed, 225 insertions(+), 15 deletions(-) create mode 100644 test/programs/fn-cfn-table.flan diff --git a/TODO.org b/TODO.org index f395baa5..1584ed26 100644 --- a/TODO.org +++ b/TODO.org @@ -1006,13 +1006,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 diff --git a/docs/BUILT.md b/docs/BUILT.md index 567337f6..e84407e9 100644 --- a/docs/BUILT.md +++ b/docs/BUILT.md @@ -4336,8 +4336,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/lib/check.ml b/lib/check.ml index 4bb9018c..27cd37a2 100644 --- a/lib/check.ml +++ b/lib/check.ml @@ -1134,12 +1134,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 | _ -> () @@ -10685,6 +10692,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 diff --git a/lib/emit.ml b/lib/emit.ml index 3572b27b..5d1e8d59 100644 --- a/lib/emit.ml +++ b/lib/emit.ml @@ -3132,6 +3132,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; @@ -3139,6 +3142,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. @@ -4875,6 +4891,9 @@ 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) diff --git a/lib/prelude.ml b/lib/prelude.ml index 8d201c41..050013ae 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 diff --git a/lib/x86.ml b/lib/x86.ml index bcf1ae79..247b537b 100644 --- a/lib/x86.ml +++ b/lib/x86.ml @@ -1916,6 +1916,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 +2705,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, \ diff --git a/runtime/flan_rt.c b/runtime/flan_rt.c index b759c63a..c50278a0 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 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/test_acceptance.ml b/test/test_acceptance.ml index d41fa573..35c127fd 100644 --- a/test/test_acceptance.ml +++ b/test/test_acceptance.ml @@ -4663,6 +4663,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 diff --git a/test/test_flan.ml b/test/test_flan.ml index d4013662..24cfbe01 100644 --- a/test/test_flan.ml +++ b/test/test_flan.ml @@ -3595,6 +3595,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* From 23af8a4dd3b5c6067a1b8d53359939dc653a1aef Mon Sep 17 00:00:00 2001 From: Joseph Ferano Date: Fri, 25 Sep 2026 15:31:12 +0700 Subject: [PATCH 10/42] A bool arm and a dyn arm of an if meet at dyn with the bool boxed, so (or false (box "s")) answers "s" --- TODO.org | 7 ------- lib/check.ml | 31 +++++++++++++++++++++++++++++++ lib/parse.ml | 15 ++++----------- test/programs/dyn-if-truthy.flan | 7 +++++++ test/test_acceptance.ml | 2 +- 5 files changed, 43 insertions(+), 19 deletions(-) diff --git a/TODO.org b/TODO.org index 1584ed26..5d6cf540 100644 --- a/TODO.org +++ b/TODO.org @@ -848,13 +848,6 @@ 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 diff --git a/lib/check.ml b/lib/check.ml index 27cd37a2..331e5ca4 100644 --- a/lib/check.ml +++ b/lib/check.ml @@ -5998,6 +5998,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 @@ -6019,6 +6047,9 @@ 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 own_else with + | Some v -> v + | None -> match branch ctx (fun () -> in_tail (fun () -> check ctx ?want:ewant e)) with | v -> v | exception Loc.Error d diff --git a/lib/parse.ml b/lib/parse.ml index 88b824a5..64d6854f 100644 --- a/lib/parse.ml +++ b/lib/parse.ml @@ -1182,17 +1182,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 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/test_acceptance.ml b/test/test_acceptance.ml index 35c127fd..23d96f21 100644 --- a/test/test_acceptance.ml +++ b/test/test_acceptance.ml @@ -1928,7 +1928,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\ From da9f21ddcd072fe897703f5ed58c1bfe9b6a7ade Mon Sep 17 00:00:00 2001 From: Joseph Ferano Date: Fri, 25 Sep 2026 15:33:23 +0700 Subject: [PATCH 11/42] A form sent to the daemon is refused with every error in it, and an expression evaluated from the break buffer sees the stopped frame's locals --- TODO.org | 16 --- emacs/flan-cnr.el | 32 +++++- emacs/flan.el | 10 +- emacs/test-flan-cider.el | 30 +++++ lib/check.ml | 232 +++++++++++++++++++++++++++++++++------ lib/dev.ml | 92 +++++++++++----- lib/loc.ml | 1 + lib/session.ml | 76 ++++++++++++- lib/tast.ml | 59 ++++++++++ test/test_dev.ml | 47 ++++++++ test/test_session.ml | 38 +++++++ 11 files changed, 552 insertions(+), 81 deletions(-) diff --git a/TODO.org b/TODO.org index e04e66a1..80f35745 100644 --- a/TODO.org +++ b/TODO.org @@ -2021,15 +2021,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 @@ -2068,13 +2059,6 @@ 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=. diff --git a/emacs/flan-cnr.el b/emacs/flan-cnr.el index 8f29907f..1c444758 100644 --- a/emacs/flan-cnr.el +++ b/emacs/flan-cnr.el @@ -574,7 +574,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 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 +833,34 @@ 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-refresh () "Ask the program again what it is offering." (interactive) @@ -889,6 +917,8 @@ 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) (define-key map "g" #'flan-cnr-refresh) (define-key map "q" #'quit-window) diff --git a/emacs/flan.el b/emacs/flan.el index 36f78e31..55c4a446 100644 --- a/emacs/flan.el +++ b/emacs/flan.el @@ -2609,7 +2609,15 @@ breakpoint is marked from the editor, without editing the buffer\"." ;; 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 diff --git a/emacs/test-flan-cider.el b/emacs/test-flan-cider.el index 1cdcaf74..2e850c1a 100644 --- a/emacs/test-flan-cider.el +++ b/emacs/test-flan-cider.el @@ -1477,6 +1477,36 @@ 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)))) + ;; `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/lib/check.ml b/lib/check.ml index ee0c4daf..7d7250c4 100644 --- a/lib/check.ml +++ b/lib/check.ml @@ -211,6 +211,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 () = { @@ -243,6 +256,11 @@ let new_env () = { in_field = false; classes = Hashtbl.create 8; tracks = Hashtbl.create 16; + recovering = false; + recovered = []; + poison = 0; + speculating = 0; + guard_next = false; } (* Where a named type was declared, and what it has, as a note. @@ -3527,6 +3545,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; @@ -4034,7 +4109,43 @@ 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. *) +(* 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 record_recovered env d; + 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 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 @@ -5448,6 +5559,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) @@ -5678,6 +5792,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) @@ -5851,7 +5968,10 @@ and check_recur ctx ~tail loc args = accident. *) and check_truthy 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 @@ -5877,10 +5997,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 @@ -5892,9 +6013,11 @@ 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 = @@ -5962,15 +6085,23 @@ 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 + 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 @@ -6072,16 +6203,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" name + 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))) @@ -6524,6 +6658,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 -> @@ -6723,7 +6859,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 \ @@ -7223,6 +7359,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 @@ -7238,9 +7375,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 @@ -11285,7 +11423,9 @@ and instantiate env loc gname vars subst cparams cret = env.tvpreds <- saved_preds; env.chain <- saved_chain in 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 (); @@ -11408,7 +11548,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; @@ -12488,7 +12628,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 @@ -13854,7 +13994,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 -> @@ -13935,7 +14075,9 @@ let build_program ~keep_going ?tolerate (decls : Ast.decl list) : | 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)))) + tolerant fn.Ast.name (fun () -> + with_recovery env ~on:keep_going (fun () -> + Some (check_generic env fn))))) | _ -> ()) decls; let globals = @@ -13943,9 +14085,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 = @@ -13958,7 +14103,9 @@ 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 @@ -14017,8 +14164,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 @@ -14136,6 +14283,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/dev.ml b/lib/dev.ml index 7f052f25..562333ed 100644 --- a/lib/dev.ml +++ b/lib/dev.ml @@ -997,6 +997,31 @@ let stale_field (ss : Session.stale list) = (if x.Session.running then " :running t" else "")) ss) ] +(* 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 = []) t ~code ~origin ~pause = let now = liveness t in let parked_now = now = Parked in @@ -1102,20 +1127,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 +1157,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 +1200,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,7 +1216,7 @@ 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 (* Read here, beside [before], and for the same kind of reason: all @@ -1256,7 +1263,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; @@ -2406,6 +2420,30 @@ 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 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 -> + (match bound_slots t ~frame:index 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 @@ -4379,7 +4417,7 @@ let handle 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") 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 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/session.ml b/lib/session.ml index 41d45d6f..286c6e38 100644 --- a/lib/session.ml +++ b/lib/session.ml @@ -968,8 +968,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 @@ -2507,7 +2512,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 Reader.read_all ~file:origin src with | [ f ] -> f @@ -2556,7 +2622,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 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/test/test_dev.ml b/test/test_dev.ml index d5446668..dfc4a1fb 100644 --- a/test/test_dev.ml +++ b/test/test_dev.ml @@ -127,6 +127,51 @@ let status r = let contains_sub = Test_support.contains +(* 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 + (* ── The one verb whose reply races the process it ends ─────────────── *) (* [abort] is answered twice over, and the two answers are not ordered. On the @@ -2284,6 +2329,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 @@ -6141,6 +6187,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 diff --git a/test/test_session.ml b/test/test_session.ml index 5af415c9..e152b4c5 100644 --- a/test/test_session.ml +++ b/test/test_session.ml @@ -1764,4 +1764,42 @@ 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); + (* 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" () From f67498c789cba29400b667185ed24a34c7953c0d Mon Sep 17 00:00:00 2001 From: Joseph Ferano Date: Fri, 25 Sep 2026 15:35:23 +0700 Subject: [PATCH 12/42] A re-run under --two-process builds the program again from the session and starts it in a new process, and the daemon outlives a finished child --- TODO.org | 6 -- lib/dev.ml | 152 ++++++++++++++++++++++++++++++++++++----------- lib/program.ml | 5 +- lib/session.ml | 9 ++- test/test_dev.ml | 73 +++++++++++++++++++---- 5 files changed, 189 insertions(+), 56 deletions(-) diff --git a/TODO.org b/TODO.org index bc1164ef..81a86da6 100644 --- a/TODO.org +++ b/TODO.org @@ -1543,12 +1543,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 diff --git a/lib/dev.ml b/lib/dev.ml index 5d9f3a17..5c1077db 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 @@ -822,7 +826,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 @@ -833,7 +838,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 @@ -3658,7 +3663,58 @@ 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 -> + let s = t.session in + (match Session.stale_sites s.Session.built s.Session.program with + | (x : Session.stale) :: _ as ss -> + error ~loc:(Loc.to_string x.Session.at) + (Printf.sprintf + "a re-run builds the program again, and %d call%s compiled for a \ + signature %s function no longer has, starting with %s calling %s \ + here. Recompile the caller with C-c C-c, or change %s back, and \ + ask again" + (List.length ss) + (if List.length ss = 1 then " was" else "s were") + (if List.length ss = 1 then "its" else "their") + x.Session.caller x.Session.target x.Session.target) + | [] -> + (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)) + 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 @@ -5057,8 +5113,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 @@ -5071,7 +5130,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 () | _ -> @@ -5246,19 +5308,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.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 @@ -5294,23 +5359,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 } @@ -5324,9 +5405,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 @@ -6169,7 +6253,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 } 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/session.ml b/lib/session.ml index 41d45d6f..dd6c2292 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. @@ -782,6 +782,13 @@ 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. *) +let rehost t = + t.host <- t.program; + t.built <- record_built t.env t.program t.program.Tast.fns SM.empty; + t.live <- SM.empty + (* [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 diff --git a/test/test_dev.ml b/test/test_dev.ml index dcbff377..c1f02dc8 100644 --- a/test/test_dev.ml +++ b/test/test_dev.ml @@ -5121,20 +5121,69 @@ 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" + end; ignore (ask "(:op \"close\")"); Unix.close tc end; From 1716b146cd8912bb426fc85c5d63b09c50c0de83 Mon Sep 17 00:00:00 2001 From: Joseph Ferano Date: Fri, 25 Sep 2026 15:35:36 +0700 Subject: [PATCH 13/42] A condition check_truthy has already refused is refused again from memory, so a retry through nested not is linear and keeps its message --- TODO.org | 8 -------- lib/check.ml | 37 +++++++++++++++++++++++++++++++------ test/test_flan.ml | 17 +++++++++++++++++ 3 files changed, 48 insertions(+), 14 deletions(-) diff --git a/TODO.org b/TODO.org index 5d6cf540..b0d30b34 100644 --- a/TODO.org +++ b/TODO.org @@ -848,14 +848,6 @@ 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 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 diff --git a/lib/check.ml b/lib/check.ml index 331e5ca4..252cafba 100644 --- a/lib/check.ml +++ b/lib/check.ml @@ -4091,6 +4091,14 @@ 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 * ctx * Loc.diag) list ref = ref [] +let truthy_depth = ref 0 + let rec check ctx ?want (e : Ast.expr) : Tast.expr = let place = ctx.place_ok in ctx.place_ok <- false; @@ -5887,12 +5895,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 @@ -5907,6 +5915,23 @@ 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 = + match + List.find_opt (fun (n, cx, _) -> n == c && cx == ctx) !truthy_failed + with + | Some (_, _, d) -> raise (Loc.Error d) + | None -> + 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, ctx, d) :: !truthy_failed; + raise ex) + +and check_truthy_once ctx c = let loc = c.Ast.loc in match check ctx c with | c0 when c0.Tast.ty = Types.Dyn -> diff --git a/test/test_flan.ml b/test/test_flan.ml index 24cfbe01..131f7ab5 100644 --- a/test/test_flan.ml +++ b/test/test_flan.ml @@ -5682,6 +5682,23 @@ 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 + match Watchdog.within 5 (fun () -> checked deep) with + | _ -> check "a deep not nest over an i32 is refused" false + | exception Watchdog.Timeout -> + check "a deep not nest over an i32 fails fast" false + | exception Loc.Error { Loc.dmsg; _ } -> + 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 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" From e616a29cebfd5a3a485f916225ce764ffb6025be Mon Sep 17 00:00:00 2001 From: Joseph Ferano Date: Fri, 25 Sep 2026 15:37:26 +0700 Subject: [PATCH 14/42] A parameter vector paired by a lowercase type the program declares is warned at, naming the type and where it is declared --- TODO.org | 7 ------ lib/check.ml | 63 ++++++++++++++++++++++++++++++++++++++++++++--- test/test_flan.ml | 23 +++++++++++++++++ 3 files changed, 83 insertions(+), 10 deletions(-) diff --git a/TODO.org b/TODO.org index b0d30b34..b92a4f8e 100644 --- a/TODO.org +++ b/TODO.org @@ -854,13 +854,6 @@ 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 diff --git a/lib/check.ml b/lib/check.ml index 252cafba..aee64ee2 100644 --- a/lib/check.ml +++ b/lib/check.ml @@ -1631,9 +1631,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 = +(* 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) env + (items : Ast.pitem list) : Ast.field list = let is_type_name env n = is_type_name env 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 | [] -> [] @@ -1649,6 +1677,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 @@ -1778,10 +1807,32 @@ let pair_decls env (decls : Ast.decl list) : Ast.decl list = match d.Ast.d with Ast.Defclass (n, _) -> Some n | _ -> None) decls in + (* 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 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 := []; let fn (f : Ast.fn) = match f.Ast.praw with | None -> f - | Some items -> { f with Ast.params = pair_params env items; praw = None } + | Some items -> + { f with + Ast.params = pair_params ~declared:(Hashtbl.find_opt types) env items; + praw = None } in List.map (fun (d : Ast.decl) -> @@ -14108,6 +14159,12 @@ let build_program ~keep_going ?tolerate (decls : Ast.decl list) : cannot make the next body fail — which is what makes a declaration a resync point that needs no resynchronising. *) 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 diff --git a/test/test_flan.ml b/test/test_flan.ml index 131f7ab5..1e20a2e4 100644 --- a/test/test_flan.ml +++ b/test/test_flan.ml @@ -5814,6 +5814,29 @@ 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); 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 From d0fc036bbac01378d93b2a0c9d1f8fef399e06fc Mon Sep 17 00:00:00 2001 From: Joseph Ferano Date: Fri, 25 Sep 2026 15:39:00 +0700 Subject: [PATCH 15/42] flan dev --sanitize builds the host under ASan and UBSan on LLVM, refuses --x86 by name, and the sanitize sweep drives a real session through reloads and breaks --- TODO.org | 7 ---- bin/main.ml | 12 ++++-- docs/BUILT.md | 9 ++-- lib/dev.ml | 25 +++++++---- test/dune | 4 +- test/test_sanitize.ml | 97 +++++++++++++++++++++++++++++++++++++++---- 6 files changed, 125 insertions(+), 29 deletions(-) diff --git a/TODO.org b/TODO.org index 81a86da6..e58e50d2 100644 --- a/TODO.org +++ b/TODO.org @@ -1771,13 +1771,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 diff --git a/bin/main.ml b/bin/main.ml index a2206078..1e208239 100644 --- a/bin/main.ml +++ b/bin/main.ml @@ -782,7 +782,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 @@ -792,8 +796,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 @@ -809,7 +813,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 2fc8b761..d38d0ac1 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. diff --git a/lib/dev.ml b/lib/dev.ml index 5c1077db..3d5854d6 100644 --- a/lib/dev.ml +++ b/lib/dev.ml @@ -5281,7 +5281,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 @@ -5316,7 +5316,7 @@ let two_process ?(debug = false) ?(x86 = true) ~file ~sock () = let _, kept = Build.executable ~opts:{ Build.default with Build.dev = true; Build.keep = true; - Build.debug; Build.x86 } + Build.debug; Build.sanitize; Build.x86 } ~csrcs ~lflags session.Session.host ~out:exe in match kept with @@ -6336,7 +6336,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 @@ -6354,7 +6354,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 @@ -6395,7 +6396,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 @@ -6445,5 +6456,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/test/dune b/test/dune index 48c41582..8ba05ad9 100644 --- a/test/dune +++ b/test/dune @@ -129,7 +129,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/test_sanitize.ml b/test/test_sanitize.ml index fe5c3510..b7da62a0 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; From d46067962d8dd69077522e72d441f4c28d8d47c7 Mon Sep 17 00:00:00 2001 From: Joseph Ferano Date: Fri, 25 Sep 2026 15:41:42 +0700 Subject: [PATCH 16/42] A Vec or Map parameter the function grows with push, reserve or put is warned at the parameter, naming the (Ptr ...) that reaches the caller's container --- TODO.org | 6 ---- lib/check.ml | 52 +++++++++++++++++++++++++++++++++++ test/programs/grow-param.flan | 23 ++++++++++++++++ test/test_acceptance.ml | 4 +++ test/test_flan.ml | 33 ++++++++++++++++++++++ 5 files changed, 112 insertions(+), 6 deletions(-) create mode 100644 test/programs/grow-param.flan diff --git a/TODO.org b/TODO.org index b92a4f8e..32de7f60 100644 --- a/TODO.org +++ b/TODO.org @@ -630,12 +630,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 diff --git a/lib/check.ml b/lib/check.ml index aee64ee2..c077e403 100644 --- a/lib/check.ml +++ b/lib/check.ml @@ -4150,6 +4150,39 @@ let tracked_call loc env name (tr : Shim.track) ret (args : Tast.expr list) = let truthy_failed : (Ast.expr * ctx * Loc.diag) list ref = ref [] let truthy_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) = + match target.Tast.e, target.Tast.ty, !grow_params with + | Tast.Local s, ((Types.Vec _ | Types.Map _) as t), (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 + grow_warnings := + Loc.diag ~kind:"check/grown-parameter" p.Ast.floc + (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) + :: !grow_warnings + | _ -> ()) + | _ -> () + let rec check ctx ?want (e : Ast.expr) : Tast.expr = let place = ctx.place_ok in ctx.place_ok <- false; @@ -9197,6 +9230,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. *) @@ -9228,6 +9262,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 @@ -9524,6 +9559,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 @@ -12866,6 +12902,15 @@ 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_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; + Fun.protect ~finally:(fun () -> grow_params := grow_saved) @@ fun () -> let body = match fn.Ast.fbody with | [] -> @@ -14158,6 +14203,7 @@ 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. *) + grow_warnings := []; let decls = collect env decls in if !print_warnings then List.iter @@ -14211,6 +14257,12 @@ let build_program ~keep_going ?tolerate (decls : Ast.decl list) : | _ -> 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 diff --git a/test/programs/grow-param.flan b/test/programs/grow-param.flan new file mode 100644 index 00000000..a3f12362 --- /dev/null +++ b/test/programs/grow-param.flan @@ -0,0 +1,23 @@ +;;;; 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. + +(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 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)) + 0) diff --git a/test/test_acceptance.ml b/test/test_acceptance.ml index 23d96f21..b3869e17 100644 --- a/test/test_acceptance.ml +++ b/test/test_acceptance.ml @@ -622,6 +622,10 @@ let () = "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. *) + (* A grown container parameter reaches the caller only through a Ptr. *) + outputs "a grown parameter" "programs/grow-param.flan" "0\n2\n2\n1\n"; + outputs ~x86:true "a grown parameter, --x86" "programs/grow-param.flan" + "0\n2\n2\n1\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"; diff --git a/test/test_flan.ml b/test/test_flan.ml index 1e20a2e4..6150470e 100644 --- a/test/test_flan.ml +++ b/test/test_flan.ml @@ -5837,6 +5837,39 @@ let () = (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); + 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 From 9a914404861292f585edc34d03f80e8045e66c9a Mon Sep 17 00:00:00 2001 From: Joseph Ferano Date: Fri, 25 Sep 2026 15:43:24 +0700 Subject: [PATCH 17/42] C-c C-s installs a defn that stops before each form of its body, and the break buffer steps it with s and runs the rest of the call with c --- TODO.org | 12 ++-- emacs/MANUAL.md | 9 +++ emacs/flan-cnr.el | 64 +++++++++++++++++-- emacs/flan-mode.el | 3 + emacs/flan.el | 23 ++++++- emacs/test-flan-cider.el | 54 ++++++++++++++++ lib/ast.ml | 65 ++++++++++++++++++++ lib/dev.ml | 13 +++- lib/prelude.ml | 12 ++++ lib/session.ml | 20 +++++- test/test_dev.ml | 130 +++++++++++++++++++++++++++++++++++++++ 11 files changed, 385 insertions(+), 20 deletions(-) diff --git a/TODO.org b/TODO.org index 80f35745..fda1a4c8 100644 --- a/TODO.org +++ b/TODO.org @@ -2029,14 +2029,10 @@ 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 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, diff --git a/emacs/MANUAL.md b/emacs/MANUAL.md index 34130ffa..3192aa39 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 | diff --git a/emacs/flan-cnr.el b/emacs/flan-cnr.el index 1c444758..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 e eval in frame 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 @@ -861,6 +874,41 @@ local of, and CODE is read from the minibuffer." 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) @@ -920,6 +968,9 @@ anyone who would rather TAB always moved." ;; 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 @@ -1162,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-mode.el b/emacs/flan-mode.el index 8785eebc..3c5b9080 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) @@ -448,6 +449,8 @@ For `syntax-propertize-function'." ;; reads as the client being broken rather than as the key being free. (define-key map (kbd "C-M-x") #'flan-eval-defun) (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-x C-e") #'flan-eval-last-sexp) (define-key map (kbd "C-c C-z") #'flan-connect) (define-key map (kbd "C-c C-q") #'flan-disconnect) diff --git a/emacs/flan.el b/emacs/flan.el index 55c4a446..50ddbcdf 100644 --- a/emacs/flan.el +++ b/emacs/flan.el @@ -2590,7 +2590,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 @@ -2605,7 +2605,8 @@ breakpoint is marked from the editor, without editing the buffer\"." (append (list :op "eval" :code code :file (or buffer-file-name "")) (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. @@ -2632,6 +2633,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)) @@ -2913,6 +2918,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 2e850c1a..31407150 100644 --- a/emacs/test-flan-cider.el +++ b/emacs/test-flan-cider.el @@ -1507,6 +1507,60 @@ would be overwritten. Look again and re-do the edit") (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)))) + +;; 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/lib/ast.ml b/lib/ast.ml index bc5f0d67..362537c6 100644 --- a/lib/ast.ml +++ b/lib/ast.ml @@ -481,6 +481,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/dev.ml b/lib/dev.ml index 562333ed..ca4c1aae 100644 --- a/lib/dev.ml +++ b/lib/dev.ml @@ -1022,7 +1022,7 @@ let errors_reply (ds : Loc.diag list) = String.sub e 0 (String.length e - 1) ^ " " ^ String.concat " " (errors_field ds) ^ ")" -let eval ?forms ?base ?(extra = []) t ~code ~origin ~pause = +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 @@ -1046,7 +1046,7 @@ let eval ?forms ?base ?(extra = []) t ~code ~origin ~pause = 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 -> @@ -1109,6 +1109,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) @@ -4399,7 +4400,13 @@ let handle 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 diff --git a/lib/prelude.ml b/lib/prelude.ml index 904da3c9..e097d34e 100644 --- a/lib/prelude.ml +++ b/lib/prelude.ml @@ -240,6 +240,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 diff --git a/lib/session.ml b/lib/session.ml index 286c6e38..59b81b99 100644 --- a/lib/session.ml +++ b/lib/session.ml @@ -787,7 +787,7 @@ let rerun t = t.live <- SM.empty 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 -> Reader.read_all ~file:origin src in @@ -877,6 +877,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 @@ -1504,6 +1513,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 diff --git a/test/test_dev.ml b/test/test_dev.ml index dfc4a1fb..b781671e 100644 --- a/test/test_dev.ml +++ b/test/test_dev.ml @@ -8759,6 +8759,136 @@ let () = hook_block ~llvm:false; hook_block ~llvm:true; + (* ── The stepper ───────────────────────────────────────────────── + [dev-pause.flan] calls [step] every 5ms. Sent with [:step t], a call + stops before each form of its body: first the (set ...), then, after + [next], the [ticks] it answers. [continue] runs the rest of the call, + and the next call steps again. A plain evaluation takes it out. Under + both backends, each with its own daemon. *) + let stepper ~llvm = + let what = if llvm then "llvm " else "x86 " in + let ssock = tmp (what ^ "step.sock") and sout = tmp (what ^ "step.out") in + (try Sys.remove ssock with Sys_error _ -> ()); + let sfd = Unix.openfile sout [ Unix.O_WRONLY; Unix.O_CREAT; Unix.O_TRUNC ] 0o600 in + let spid = + Unix.create_process flan + (Array.append + [| flan; "dev"; "programs/dev-pause.flan"; "-s"; ssock |] + (if llvm then [| "--llvm" |] else [||])) + Unix.stdin sfd Unix.stderr + in + Unix.close sfd; + if not (listening ~pid:spid ssock) then + fail "%sstepper daemon %s" what !listen_why + else begin + let c = connect ssock in + let ask = request c in + 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; + (try Unix.close c with Unix.Unix_error _ -> ()) + end; + (try Unix.kill spid Sys.sigkill with Unix.Unix_error _ -> ()); + (try ignore (Unix.waitpid [] spid) with Unix.Unix_error _ -> ()); + List.iter (fun f -> try Sys.remove f with Sys_error _ -> ()) [ ssock; sout ] + in + stepper ~llvm:false; + stepper ~llvm:true; + List.iter (fun f -> try Sys.remove f with Sys_error _ -> ()) [ sock; out; bsock; bout ]; Test_support.report ~label:"dev" () From 527da3763373ae67b254b90b4b8f36d179139def Mon Sep 17 00:00:00 2001 From: Joseph Ferano Date: Fri, 25 Sep 2026 15:57:40 +0700 Subject: [PATCH 18/42] An evaluated expression's module is unloaded when its only strings are literals or registry names, because a literal is a copy the process keeps --- TODO.org | 15 +++----- lib/emit.ml | 41 +++++++++++++++----- lib/x86.ml | 31 ++++++++++----- runtime/flan_dev.c | 50 ++++++++++++++++++++++++ test/test_dev.ml | 91 ++++++++++++++++++++++++++++++++++++++------ test/test_session.ml | 34 ++++++++++------- 6 files changed, 211 insertions(+), 51 deletions(-) diff --git a/TODO.org b/TODO.org index e58e50d2..ef81b3c1 100644 --- a/TODO.org +++ b/TODO.org @@ -1498,10 +1498,6 @@ 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. - ** 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 host's cell for that name, so the prelude's calls compiled into the host follow it; @@ -1822,11 +1818,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 after an allocating thunk once answered without the value +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", so the global +was intact and the first read's reply lacked the value: not the collector. 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 diff --git a/lib/emit.ml b/lib/emit.ml index 3572b27b..390aae7e 100644 --- a/lib/emit.ml +++ b/lib/emit.ml @@ -536,6 +536,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 @@ -2562,6 +2568,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" @@ -4957,6 +4973,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) @@ -5273,7 +5291,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; @@ -5749,6 +5767,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 @@ -5868,7 +5887,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) -> @@ -5887,8 +5906,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)); @@ -5898,7 +5919,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 @@ -5967,10 +5988,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, diff --git a/lib/x86.ml b/lib/x86.ml index bcf1ae79..b48d64d6 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) @@ -1812,6 +1813,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. *) @@ -5315,6 +5326,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) @@ -5419,7 +5431,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); @@ -5598,13 +5613,11 @@ 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 = [] diff --git a/runtime/flan_dev.c b/runtime/flan_dev.c index 245541a0..6663f368 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 diff --git a/test/test_dev.ml b/test/test_dev.ml index c1f02dc8..e487f855 100644 --- a/test/test_dev.ml +++ b/test/test_dev.ml @@ -6604,12 +6604,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. *) @@ -6629,11 +6629,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 @@ -6642,7 +6648,48 @@ 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 end; ignore (request c "(:op \"close\")"); (try Unix.close c with Unix.Unix_error _ -> ()); @@ -8761,6 +8808,28 @@ 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] diff --git a/test/test_session.ml b/test/test_session.ml index 5af415c9..5e50af53 100644 --- a/test/test_session.ml +++ b/test/test_session.ml @@ -1315,17 +1315,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 +1531,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 +1564,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 +1628,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); From 6c8f503ebf21d20540e3d5901af5f07ada14611f Mon Sep 17 00:00:00 2001 From: Joseph Ferano Date: Fri, 25 Sep 2026 16:08:13 +0700 Subject: [PATCH 19/42] A --two-process re-run checks the whole program before building it and refuses at a stale caller, and a change made while the child has ended waits in the session for the re-run --- TODO.org | 19 ++++++------ lib/dev.ml | 78 ++++++++++++++++++++++++++++-------------------- lib/session.ml | 17 +++++++++-- test/test_dev.ml | 57 ++++++++++++++++++++++++++++++++++- 4 files changed, 126 insertions(+), 45 deletions(-) diff --git a/TODO.org b/TODO.org index ef81b3c1..d721a04c 100644 --- a/TODO.org +++ b/TODO.org @@ -1718,10 +1718,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, @@ -1818,12 +1819,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. -** WAIT An x86 dev session's read after an allocating thunk once answered without the value +** 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", so the global -was intact and the first read's reply lacked the value: not the collector. 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. +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 diff --git a/lib/dev.ml b/lib/dev.ml index 3d5854d6..299cfbbd 100644 --- a/lib/dev.ml +++ b/lib/dev.ml @@ -1041,7 +1041,25 @@ 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) @@ -3679,37 +3697,33 @@ let relaunch_child t relaunch = process once this one has finished. Close its window, or let it \ finish, and ask again") | Gone -> - let s = t.session in - (match Session.stale_sites s.Session.built s.Session.program with - | (x : Session.stale) :: _ as ss -> - error ~loc:(Loc.to_string x.Session.at) - (Printf.sprintf - "a re-run builds the program again, and %d call%s compiled for a \ - signature %s function no longer has, starting with %s calling %s \ - here. Recompile the caller with C-c C-c, or change %s back, and \ - ask again" - (List.length ss) - (if List.length ss = 1 then " was" else "s were") - (if List.length ss = 1 then "its" else "their") - x.Session.caller x.Session.target x.Session.target) - | [] -> - (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)) + (* 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 diff --git a/lib/session.ml b/lib/session.ml index dd6c2292..14a2fc2a 100644 --- a/lib/session.ml +++ b/lib/session.ml @@ -783,10 +783,21 @@ let restore t h = 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. *) + (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 = - t.host <- t.program; - t.built <- record_built t.env t.program t.program.Tast.fns SM.empty; + 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 (* [forms], when given, are [src] already read — [pruned] runs this over a diff --git a/test/test_dev.ml b/test/test_dev.ml index e487f855..d59907bc 100644 --- a/test/test_dev.ml +++ b/test/test_dev.ml @@ -5182,7 +5182,62 @@ let () = (await (fun () -> ignore (ask "(:op \"describe\")"); contains_sub (Buffer.contents seen) "45")) - then fail "--two-process: the new child never installed a delivery" + 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 From 4054c4921ba9724ff543f197a46c5dea1bd4f2f0 Mon Sep 17 00:00:00 2001 From: Joseph Ferano Date: Fri, 25 Sep 2026 16:08:14 +0700 Subject: [PATCH 20/42] A defstruct whose fields introduce $t or an array length $n is a generic struct, each application of it an ordinary struct copy that generic functions bind against, and a printed call is evaluated once --- TODO.org | 13 +- lib/ast.ml | 3 + lib/check.ml | 984 +++++++++++++++++++++++++----- lib/cimport.ml | 1 + lib/dev.ml | 21 +- lib/emit.ml | 7 +- lib/js.ml | 2 + lib/load.ml | 8 +- lib/parse.ml | 20 +- lib/session.ml | 11 +- lib/shim.ml | 1 + lib/types.ml | 26 +- lib/x86.ml | 1 + test/programs/generic-struct.flan | 89 +++ test/test_acceptance.ml | 12 + test/test_flan.ml | 83 ++- test/test_session.ml | 20 + 17 files changed, 1111 insertions(+), 191 deletions(-) create mode 100644 test/programs/generic-struct.flan diff --git a/TODO.org b/TODO.org index 0a5e280d..98476f68 100644 --- a/TODO.org +++ b/TODO.org @@ -750,15 +750,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. diff --git a/lib/ast.ml b/lib/ast.ml index bc5f0d67..b87d4abb 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 = diff --git a/lib/check.ml b/lib/check.ml index 0c03ca82..59e1ba1b 100644 --- a/lib/check.ml +++ b/lib/check.ml @@ -79,6 +79,44 @@ let rec slot_text = function | Sclass c -> c | Sopt s -> "(Option " ^ slot_text s ^ ")" +(* ── 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; @@ -198,13 +236,32 @@ type env = { 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; + (* 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 @@ -247,6 +304,12 @@ let new_env () = { tvpreds = []; chain = []; refused_generics = Hashtbl.create 4; + gstructs = Hashtbl.create 4; + copies = Hashtbl.create 8; + glens = Hashtbl.create 8; + lenvars = []; + len_placeholder = false; + schain = []; in_field = false; classes = Hashtbl.create 8; tracks = Hashtbl.create 16; @@ -262,6 +325,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 -> @@ -277,8 +347,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 ] @@ -1202,6 +1272,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 @@ -1234,7 +1417,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 @@ -1298,15 +1491,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. *) @@ -1323,9 +1511,154 @@ 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 env loc name targs = + let key = struct_app name targs in + if Hashtbl.mem env.copies key then key + 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; + 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 @@ -1359,12 +1692,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 @@ -1383,8 +1723,8 @@ 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, \ @@ -1423,6 +1763,13 @@ 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 + (String.concat " " (List.map (fun (p, _) -> "$" ^ p) 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. @@ -1460,18 +1807,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 \ @@ -1483,7 +1828,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 \ @@ -1514,6 +1871,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 @@ -1828,6 +2186,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. *) @@ -2004,9 +2363,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"; @@ -2016,24 +2375,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 @@ -2102,6 +2496,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 when not (String.equal p 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_ + | _ -> false) (* 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 @@ -2118,12 +2523,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 @@ -2131,6 +2553,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 @@ -2170,33 +2623,6 @@ let unconstrained env loc op ~needs (t : Types.t) = (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) - (* 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 - | 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 @@ -2223,23 +2649,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 " @@ -3042,7 +3451,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 = @@ -4260,6 +4670,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 @@ -4400,7 +4827,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)))) @@ -6022,6 +6449,101 @@ 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 + let pairs = + List.filter (fun (_, a) -> not (literal a)) pairs + @ List.filter (fun (_, a) -> literal a) pairs + in + List.iter + (fun ((f : Tast.field), (a : Ast.expr)) -> + 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 -> + if not (bind_ty subst f.Tast.fty t) then + 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, _) -> "$" ^ q) 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 @@ -6051,6 +6573,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 @@ -6058,15 +6588,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 @@ -6089,7 +6619,7 @@ and positional_struct ctx ~want loc name args = Loc.notes = d.Loc.notes @ [ Loc.note a.Ast.loc - (Printf.sprintf "this is %s's field .%s" name + (Printf.sprintf "this is %s's field .%s" shown f.Tast.fname) ] @ note }) fields args @@ -6149,6 +6679,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 -> @@ -6224,7 +6757,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))) @@ -7399,7 +7932,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) @@ -7993,7 +8526,7 @@ and file_guard ctx loc ~path_slot ~op mk_steps = (* 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)) @@ -8027,8 +8560,11 @@ 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)) @@ -8051,12 +8587,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 @@ -8080,6 +8616,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. *) @@ -8102,7 +8650,7 @@ and map_new_types ctx ~want loc args = (* 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 @@ -8110,7 +8658,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)" @@ -8596,7 +9144,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 @@ -10266,7 +10814,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 @@ -10295,7 +10843,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 @@ -10338,7 +10899,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 @@ -10634,6 +11195,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 @@ -10763,10 +11328,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? @@ -10920,9 +11485,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 = @@ -10950,7 +11520,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 @@ -10971,11 +11541,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 @@ -11180,7 +11750,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 @@ -11209,7 +11780,7 @@ and generic_call ctx ~want loc name vars pats pret args = 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" @@ -11284,13 +11855,17 @@ 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 (); @@ -12137,10 +12712,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 = [] } @@ -12181,6 +12774,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). *) @@ -12317,6 +12930,17 @@ 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 + ignore + (struct_copy env loc n + (List.map (fun (p, _) -> Types.Var p) g.gparams)) | 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 @@ -12437,7 +13061,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 @@ -12455,18 +13079,35 @@ 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 + Loc.failk "check/length-predicate" p.Ast.ploc + "$%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; 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); @@ -12477,7 +13118,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 @@ -12548,36 +13190,7 @@ 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 + let walk _ n = finite_from env n in Hashtbl.iter (fun n _ -> walk [] n) env.structs; Hashtbl.iter (fun n _ -> walk [] n) env.datas; Hashtbl.iter (fun n _ -> walk [] n) env.unions @@ -12758,8 +13371,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. *) @@ -12769,7 +13404,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 () @@ -14036,7 +14673,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 } @@ -14128,6 +14770,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)) 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 8c54e3e7..c4c78efc 100644 --- a/lib/dev.ml +++ b/lib/dev.ml @@ -1819,8 +1819,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 diff --git a/lib/emit.ml b/lib/emit.ml index 3572b27b..fac5022a 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) @@ -638,7 +638,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 = @@ -1175,7 +1176,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; diff --git a/lib/js.ml b/lib/js.ml index 221faf9e..921d4683 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 a6f70b98..724ebd4a 100644 --- a/lib/load.ml +++ b/lib/load.ml @@ -205,8 +205,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) @@ -792,8 +795,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 diff --git a/lib/parse.ml b/lib/parse.ml index e5190994..6263645a 100644 --- a/lib/parse.ml +++ b/lib/parse.ml @@ -136,7 +136,25 @@ let rec texpr (f : Form.t) : Ast.texpr = 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)) + (* 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 = + 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] + in + let arg (a : Form.t) = + match a.v with + | Int n when capitalised -> { Ast.t = Ast.Tlen n; tloc = a.loc } + | _ -> 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 = diff --git a/lib/session.ml b/lib/session.ml index 41d45d6f..1b3744e6 100644 --- a/lib/session.ml +++ b/lib/session.ml @@ -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 @@ -2610,10 +2610,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 +2641,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 ──────────────────────────────────── *) diff --git a/lib/shim.ml b/lib/shim.ml index c3070b04..bbcdd7be 100644 --- a/lib/shim.ml +++ b/lib/shim.ml @@ -256,6 +256,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 ────────────────────────── *) diff --git a/lib/types.ml b/lib/types.ml index 6e2bb57d..328909f9 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,20 @@ 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 + let rec to_string = function | Int k -> ikind_name k | Float k -> fkind_name k @@ -215,7 +236,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) @@ -232,6 +254,8 @@ let rec to_string = function Printf.sprintf "(CFn [%s] %s)" (String.concat " " (List.map to_string ps)) (to_string r) | 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 bcf1ae79..f5327a4c 100644 --- a/lib/x86.ml +++ b/lib/x86.ml @@ -532,6 +532,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 diff --git a/test/programs/generic-struct.flan b/test/programs/generic-struct.flan new file mode 100644 index 00000000..564f804e --- /dev/null +++ b/test/programs/generic-struct.flan @@ -0,0 +1,89 @@ +;;;; 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)) + +(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 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))) + (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)) + 0)) diff --git a/test/test_acceptance.ml b/test/test_acceptance.ml index 4f08c8bf..d9921546 100644 --- a/test/test_acceptance.ml +++ b/test/test_acceptance.ml @@ -3466,6 +3466,18 @@ 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\n6\n\ + 0 1 2\n3 2\n6\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 diff --git a/test/test_flan.ml b/test/test_flan.ml index d306b1d1..9d0ad68d 100644 --- a/test/test_flan.ml +++ b/test/test_flan.ml @@ -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"; @@ -2871,13 +2871,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)))"; @@ -6701,9 +6699,74 @@ let () = "(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))"; + 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_session.ml b/test/test_session.ml index 5af415c9..73ff7f35 100644 --- a/test/test_session.ml +++ b/test/test_session.ml @@ -354,6 +354,26 @@ 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); + (* 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 From 8fe2a666a18d5387f7f0ac6a7432399133ab9677 Mon Sep 17 00:00:00 2001 From: Joseph Ferano Date: Fri, 25 Sep 2026 16:09:31 +0700 Subject: [PATCH 21/42] A refused if is answered from memory for the same condition, scope and expectation, so a refused or/and chain is checked in linear time --- lib/check.ml | 54 +++++++++++++++++++++++++++++++++++++++++++---- test/test_flan.ml | 25 +++++++++++++++++++--- 2 files changed, 72 insertions(+), 7 deletions(-) diff --git a/lib/check.ml b/lib/check.ml index 8e45ace2..8acb0110 100644 --- a/lib/check.ml +++ b/lib/check.ml @@ -4147,9 +4147,31 @@ let tracked_call loc env name (tr : Shim.track) ret (args : Tast.expr list) = 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 * ctx * Loc.diag) list ref = ref [] +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 @@ -6000,10 +6022,13 @@ and check_recur ctx ~tail loc args = accident. *) and check_truthy ctx c = match - List.find_opt (fun (n, cx, _) -> n == c && cx == ctx) !truthy_failed + 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) + | Some (_, _, _, d) -> raise (Loc.Error d) | None -> + let scope = ctx.scope in incr truthy_depth; Fun.protect ~finally:(fun () -> @@ -6012,7 +6037,7 @@ and check_truthy ctx c = (fun () -> try check_truthy_once ctx c with Loc.Error d as ex -> - truthy_failed := (c, ctx, d) :: !truthy_failed; + truthy_failed := (c, scope, ctx.ret, d) :: !truthy_failed; raise ex) and check_truthy_once ctx c = @@ -6064,6 +6089,27 @@ and check_truthy_once ctx c = | exception Loc.Error _ -> check ctx ~want:Types.Bool c and check_if ctx ?(tail = false) ?want loc c t e = + 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 diff --git a/test/test_flan.ml b/test/test_flan.ml index 6150470e..2b529fc2 100644 --- a/test/test_flan.ml +++ b/test/test_flan.ml @@ -5691,14 +5691,33 @@ let () = 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 - match Watchdog.within 5 (fun () -> checked deep) with + let t0 = Unix.gettimeofday () in + match checked deep with | _ -> check "a deep not nest over an i32 is refused" false - | exception Watchdog.Timeout -> - check "a deep not nest over an i32 fails fast" 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" From ea67e058bf09800d4a9afa9a753bbf64249fdbf7 Mon Sep 17 00:00:00 2001 From: Joseph Ferano Date: Fri, 25 Sep 2026 16:15:40 +0700 Subject: [PATCH 22/42] A generic over a generic struct calls another at the same struct variables, and a struct copy is a map key and a function-value parameter on both backends --- lib/check.ml | 4 ++-- test/programs/generic-struct.flan | 19 +++++++++++++++++++ test/test_acceptance.ml | 2 +- 3 files changed, 22 insertions(+), 3 deletions(-) diff --git a/lib/check.ml b/lib/check.ml index 59e1ba1b..feb08cd9 100644 --- a/lib/check.ml +++ b/lib/check.ml @@ -2502,11 +2502,11 @@ let rec bind_ty ?(widen = false) ?(ro = true) subst (pat : Types.t) 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 when not (String.equal p a) -> + | 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_ - | _ -> false) + | _ -> 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 diff --git a/test/programs/generic-struct.flan b/test/programs/generic-struct.flan index 564f804e..f080c4e4 100644 --- a/test/programs/generic-struct.flan +++ b/test/programs/generic-struct.flan @@ -19,6 +19,11 @@ 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 @@ -53,6 +58,11 @@ ;; 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) @@ -86,4 +96,13 @@ (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/test_acceptance.ml b/test/test_acceptance.ml index d9921546..a61d9c18 100644 --- a/test/test_acceptance.ml +++ b/test/test_acceptance.ml @@ -3472,7 +3472,7 @@ let () = 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\n6\n\ - 0 1 2\n3 2\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" From b51b7d0a53f62df17662e13643c43f3907b67f9f Mon Sep 17 00:00:00 2001 From: Joseph Ferano Date: Fri, 25 Sep 2026 16:20:08 +0700 Subject: [PATCH 23/42] A refusal in a prelude generic's body stands at the call that asked for the copy, with the prelude's line as a note --- lib/check.ml | 34 ++++++++++++++++++++++++++-------- test/test_flan.ml | 31 +++++++++++++++++++++++++++++++ 2 files changed, 57 insertions(+), 8 deletions(-) diff --git a/lib/check.ml b/lib/check.ml index 8b6df651..d69941fc 100644 --- a/lib/check.ml +++ b/lib/check.ml @@ -12049,16 +12049,34 @@ and instantiate env loc gname vars subst cparams cret = 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) -> + Loc.Error + (Loc.sort_notes + { d with + Loc.dloc = loc; + dmsg = + Printf.sprintf "%s cannot be made at %s. In its body: %s" + gname (at ()) d.Loc.dmsg; + notes = + d.Loc.notes + @ [ Loc.note d.Loc.dloc + (Printf.sprintf "in %s's body, in the prelude" gname) ]; + expansion = None }) | Loc.Error d when d.Loc.dloc <> loc -> - let at = - String.concat ", " - (List.map - (fun v -> Printf.sprintf "$%s = %s" v - (Types.to_string (List.assoc v subst))) - vars) - in Loc.Error (Loc.sort_notes { d with @@ -12066,7 +12084,7 @@ and instantiate env loc gname vars subst cparams cret = d.Loc.notes @ [ Loc.note loc (Printf.sprintf "%s is instantiated at %s here" - gname at) ] }) + gname (at ())) ] }) | e -> e in (* A copy whose body did not check is not a copy. Both entries go back diff --git a/test/test_flan.ml b/test/test_flan.ml index 9d0ad68d..1ab6d401 100644 --- a/test/test_flan.ml +++ b/test/test_flan.ml @@ -6017,6 +6017,37 @@ let () = = [ "show is instantiated at $t = (CFn [] i32) here"; "outer is instantiated at $t = (CFn [] i32) here" ])); + (* 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)" + && 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 From 7b3e7f0efa1b70ec387abc9e72329551351bde18 Mon Sep 17 00:00:00 2001 From: Joseph Ferano Date: Fri, 25 Sep 2026 16:22:27 +0700 Subject: [PATCH 24/42] A program's global or type cannot change what the prelude means: a type variable wins over a global in a type position, prelude signatures pair against prelude types, and a global or type spelled like a built-in type is refused --- lib/check.ml | 43 +++++++++++++---------- lib/parse.ml | 58 +++++++++++++++++++++++++------- test/programs/prelude-names.flan | 22 ++++++++++++ test/test_acceptance.ml | 5 +++ test/test_flan.ml | 11 ++++++ 5 files changed, 109 insertions(+), 30 deletions(-) create mode 100644 test/programs/prelude-names.flan diff --git a/lib/check.ml b/lib/check.ml index 8acb0110..bee40258 100644 --- a/lib/check.ml +++ b/lib/check.ml @@ -1640,9 +1640,9 @@ let dyn_param_or_typo env n loc = [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) env - (items : Ast.pitem list) : Ast.field list = - let is_type_name env n = is_type_name env n || also n in +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 @@ -1814,7 +1814,8 @@ let pair_decls env (decls : Ast.decl list) : Ast.decl list = List.iter (fun (d : Ast.decl) -> let add n what = - if d.Ast.dloc.Loc.file <> Prelude.file then + 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 @@ -1826,16 +1827,22 @@ let pair_decls env (decls : Ast.decl list) : Ast.decl list = | _ -> ()) decls; pairing_warnings := []; - let fn (f : Ast.fn) = + (* 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 -> + let hide n = prelude && Hashtbl.mem types n in { f with - Ast.params = pair_params ~declared:(Hashtbl.find_opt types) env items; + 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 @@ -1849,9 +1856,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 @@ -8267,14 +8274,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 || (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 = @@ -8307,9 +8320,7 @@ and vec_new_elem ctx ~want loc args = | a :: rest when type_of_expr a <> None -> Some (resolve ctx.env (Option.get (type_of_expr 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 @@ -8372,9 +8383,7 @@ 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. *) diff --git a/lib/parse.ml b/lib/parse.ml index 64d6854f..27541a5c 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 @@ -1403,7 +1429,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 @@ -1413,16 +1445,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 \ @@ -1430,7 +1462,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. @@ -1473,7 +1505,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 @@ -1598,7 +1630,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) -> @@ -1691,7 +1723,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 @@ -1841,11 +1873,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 \ @@ -1884,8 +1916,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: 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/test_acceptance.ml b/test/test_acceptance.ml index b3869e17..4c44b881 100644 --- a/test/test_acceptance.ml +++ b/test/test_acceptance.ml @@ -622,6 +622,11 @@ let () = "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\n"; outputs ~x86:true "a grown parameter, --x86" "programs/grow-param.flan" diff --git a/test/test_flan.ml b/test/test_flan.ml index 2b529fc2..6b4d9986 100644 --- a/test/test_flan.ml +++ b/test/test_flan.ml @@ -3216,6 +3216,17 @@ let () = 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))))"; From 730730a1a7b1fe3b408765d122024668e84de9a5 Mon Sep 17 00:00:00 2001 From: Joseph Ferano Date: Fri, 25 Sep 2026 16:23:19 +0700 Subject: [PATCH 25/42] A relocated prelude refusal's note says only that the refusal is there, since the notes before it name which body --- lib/check.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lib/check.ml b/lib/check.ml index d69941fc..c9c6a0df 100644 --- a/lib/check.ml +++ b/lib/check.ml @@ -12074,7 +12074,7 @@ and instantiate env loc gname vars subst cparams cret = notes = d.Loc.notes @ [ Loc.note d.Loc.dloc - (Printf.sprintf "in %s's body, in the prelude" gname) ]; + "the refusal is here, in the prelude" ]; expansion = None }) | Loc.Error d when d.Loc.dloc <> loc -> Loc.Error From 83dc716133cd3210c1931b65ab8abe49d494f133 Mon Sep 17 00:00:00 2001 From: Joseph Ferano Date: Fri, 25 Sep 2026 16:32:49 +0700 Subject: [PATCH 26/42] A program's or a session's defn named as a macro shadows the macro for its calls, with the shadowing warning a prelude function gets --- lib/load.ml | 1 + lib/macro.ml | 29 +++++++++++++++++++++++++++++ lib/parse.ml | 14 ++++++++++++-- lib/session.ml | 18 +++++++++++++++--- test/programs/shadow-prelude.flan | 10 ++++++++++ test/test_acceptance.ml | 5 ++++- test/test_session.ml | 13 +++++++++++++ 7 files changed, 84 insertions(+), 6 deletions(-) diff --git a/lib/load.ml b/lib/load.ml index 70bb75cb..301babc1 100644 --- a/lib/load.ml +++ b/lib/load.ml @@ -1618,6 +1618,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/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 27541a5c..f148fe2e 100644 --- a/lib/parse.ml +++ b/lib/parse.ml @@ -2094,15 +2094,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/session.ml b/lib/session.ml index c8553887..fd88e30d 100644 --- a/lib/session.ml +++ b/lib/session.ml @@ -787,6 +787,18 @@ let rerun t = t.live <- SM.empty 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. *) +(* 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 + let eval ?(origin = "") ?base ?forms ?pause ?(running = true) t src : change = let forms = match forms with Some f -> f | None -> Reader.read_all ~file:origin src @@ -794,7 +806,7 @@ let eval ?(origin = "") ?base ?forms ?pause ?(running = true) t src : chan (* 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 @@ -2526,7 +2538,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 @@ -2699,7 +2711,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/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/test_acceptance.ml b/test/test_acceptance.ml index 4c44b881..67e90db1 100644 --- a/test/test_acceptance.ml +++ b/test/test_acceptance.ml @@ -588,7 +588,7 @@ 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; @@ -7138,6 +7138,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_session.ml b/test/test_session.ml index 5af415c9..0f85f85b 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))"; From 00fd0223306a75c39aa4ed2039e129b91c911907 Mon Sep 17 00:00:00 2001 From: Joseph Ferano Date: Fri, 25 Sep 2026 16:37:05 +0700 Subject: [PATCH 27/42] A call through a null CFn parks a dev program in the break loop with NullCall named and continue takeable, on LLVM and x86 --- test/programs/dev-break-nullcall.flan | 26 +++++++++ test/test_dev.ml | 82 +++++++++++++++++++++++++++ 2 files changed, 108 insertions(+) create mode 100644 test/programs/dev-break-nullcall.flan 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/test_dev.ml b/test/test_dev.ml index 7cf14617..4a81e008 100644 --- a/test/test_dev.ml +++ b/test/test_dev.ml @@ -2162,6 +2162,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 From 96dbcb1f2fa3c11d501496356d487949ee7d1546 Mon Sep 17 00:00:00 2001 From: Joseph Ferano Date: Fri, 25 Sep 2026 16:37:43 +0700 Subject: [PATCH 28/42] An expression that makes a function value keeps its module mapped, a process a merged program starts does not take the session's socket, and an evaluation's value is its own expression's and not one a restart resumed --- lib/dev.ml | 30 +++++++++- lib/emit.ml | 40 ++++++++++++- lib/x86.ml | 2 +- test/test_agent.ml | 117 +++++++++++++++++++++----------------- test/test_dev.ml | 50 +++++++++++++++- vendor/agent/flan_agent.c | 38 ++++++++++++- 6 files changed, 216 insertions(+), 61 deletions(-) diff --git a/lib/dev.ml b/lib/dev.ml index 2ec66a11..bb5737f0 100644 --- a/lib/dev.ml +++ b/lib/dev.ml @@ -283,6 +283,19 @@ let stop_reply t = 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. *) @@ -1253,6 +1266,10 @@ let eval_expr t ~code ~origin ~pause = match Session.eval_expr ~origin ~pause 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 @@ -1406,9 +1423,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 diff --git a/lib/emit.ml b/lib/emit.ml index c1e0dc3f..99605800 100644 --- a/lib/emit.ml +++ b/lib/emit.ml @@ -5770,6 +5770,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 @@ -6045,7 +6082,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/x86.ml b/lib/x86.ml index e781201d..09d98367 100644 --- a/lib/x86.ml +++ b/lib/x86.ml @@ -5621,7 +5621,7 @@ let redefinition ~checks ?(dev = true) ?(known = fun _ -> true) 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/test/test_agent.ml b/test/test_agent.ml index f4847b28..93ba88e0 100644 --- a/test/test_agent.ml +++ b/test/test_agent.ml @@ -65,8 +65,9 @@ let send path line = binary is the parent of every program it starts, which is the --two-process shape. *) let daemon_env path = - [| "FLAN_AGENT_SOCKET=" ^ path; - "FLAN_AGENT_OWNER=" ^ string_of_int (Unix.getpid ()) |] + 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 @@ -342,59 +343,71 @@ let () = 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 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=1" |] + 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 - 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 "a program with someone else's FLAN_AGENT_SOCKET announced no \ - socket of its own"; - (try Unix.kill spid Sys.sigkill with Unix.Unix_error _ -> ()) - | Some p -> - if p = stolen then fail "the inherited path was bound: %S" p; - if not (await (fun () -> Sys.file_exists p)) then - fail "nothing was bound at the announced %S" 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 "the program with an inherited variable never finished" - end); - (match In_channel.with_open_bin stolen In_channel.input_all with - | "the session's" -> () - | _ -> fail "the inherited FLAN_AGENT_SOCKET's file was replaced" - | exception Sys_error _ -> - fail "the inherited FLAN_AGENT_SOCKET's file was removed"); + (* 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; stolen; serr; tmp "stolen.out" ]; + [ aexe; aso; aout; aerr; bad ]; (* ── No (agent/start) at all ────────────────────────────────────── *) diff --git a/test/test_dev.ml b/test/test_dev.ml index a92747cd..13bd9784 100644 --- a/test/test_dev.ml +++ b/test/test_dev.ml @@ -6784,7 +6784,38 @@ let () = (%s)" backend (Option.value ~default:"" (Wire.string_field r "value")) (said r) - end + 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 _ -> ()); @@ -8958,6 +8989,23 @@ let () = "(: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 diff --git a/vendor/agent/flan_agent.c b/vendor/agent/flan_agent.c index 5cc5c027..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 @@ -1335,6 +1346,8 @@ int32_t flan_agent_poll(void) { 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); @@ -1920,6 +1933,14 @@ static void handle_line(char *line, sink *o) { * 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]; @@ -2199,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; } @@ -2498,8 +2521,17 @@ static const char *daemon_socket(void) { return NULL; pid = strtol(own, &end, 10); if (end == own || *end != '\0' || pid <= 0) return NULL; - if (pid != (long)getpid() && pid != (long)getppid()) return NULL; - return env; + 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. From 43c7494d54ed59bf58be6ee3179f952976c57a7b Mon Sep 17 00:00:00 2001 From: Joseph Ferano Date: Fri, 25 Sep 2026 16:40:39 +0700 Subject: [PATCH 29/42] A Vec or Map field grown through a struct parameter taken by value is warned at the parameter, naming the field path and the (Ptr ...) that reaches the caller's --- lib/check.ml | 54 ++++++++++++++++++++++++++++------- test/programs/grow-param.flan | 14 ++++++++- test/test_acceptance.ml | 4 +-- test/test_flan.ml | 19 ++++++++++++ 4 files changed, 77 insertions(+), 14 deletions(-) diff --git a/lib/check.ml b/lib/check.ml index bee40258..8b40ec8f 100644 --- a/lib/check.ml +++ b/lib/check.ml @@ -4190,8 +4190,28 @@ 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) = - match target.Tast.e, target.Tast.ty, !grow_params with - | Tast.Local s, ((Types.Vec _ | Types.Map _) as t), (c, ps) :: _ when c == ctx -> + (* 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 @@ -4199,16 +4219,28 @@ let note_grown ctx op loc (target : Tast.expr) = (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 - (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) - :: !grow_warnings + Loc.diag ~kind:"check/grown-parameter" p.Ast.floc msg :: !grow_warnings | _ -> ()) | _ -> () diff --git a/test/programs/grow-param.flan b/test/programs/grow-param.flan index a3f12362..4e0186c4 100644 --- a/test/programs/grow-param.flan +++ b/test/programs/grow-param.flan @@ -1,11 +1,17 @@ ;;;; 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. +;;;; 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) @@ -20,4 +26,10 @@ (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/test_acceptance.ml b/test/test_acceptance.ml index 67e90db1..ffdc2da2 100644 --- a/test/test_acceptance.ml +++ b/test/test_acceptance.ml @@ -628,9 +628,9 @@ let () = 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\n"; + 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\n"; + "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"; diff --git a/test/test_flan.ml b/test/test_flan.ml index 6b4d9986..f0b689f6 100644 --- a/test/test_flan.ml +++ b/test/test_flan.ml @@ -5896,6 +5896,25 @@ let () = | 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); 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)))" From 37938db7c2f24652b94c511262003e87434feddf Mon Sep 17 00:00:00 2001 From: Joseph Ferano Date: Fri, 25 Sep 2026 16:47:46 +0700 Subject: [PATCH 30/42] A call through a failed local is not reported and a miscounted call's arguments are, eval-in-frame answers slotless frames and ended stops, flan dev links its own agent, and the daemon buffer colours only file:line:col diagnostics --- TODO.org | 5 + emacs/MANUAL.md | 1 + emacs/flan.el | 9 ++ emacs/test-flan-cider.el | 24 ++++ emacs/test-flan.el | 8 +- lib/check.ml | 36 ++++- lib/dev.ml | 57 ++++++-- test/test_dev.ml | 275 ++++++++++++++++++++------------------- test/test_session.ml | 18 +++ 9 files changed, 284 insertions(+), 149 deletions(-) diff --git a/TODO.org b/TODO.org index de91143d..4cc97b73 100644 --- a/TODO.org +++ b/TODO.org @@ -2015,6 +2015,11 @@ 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. +** 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 diff --git a/emacs/MANUAL.md b/emacs/MANUAL.md index 0cc330e0..be05ee23 100644 --- a/emacs/MANUAL.md +++ b/emacs/MANUAL.md @@ -1195,6 +1195,7 @@ Use `C-c C-g` if you need frames. | `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.el b/emacs/flan.el index 3fbcdd24..ad175078 100644 --- a/emacs/flan.el +++ b/emacs/flan.el @@ -428,6 +428,15 @@ 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)) diff --git a/emacs/test-flan-cider.el b/emacs/test-flan-cider.el index 31407150..16f65fc8 100644 --- a/emacs/test-flan-cider.el +++ b/emacs/test-flan-cider.el @@ -1540,6 +1540,30 @@ would be overwritten. Look again and re-do the edit") (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 diff --git a/emacs/test-flan.el b/emacs/test-flan.el index 5fa5cd5d..952cb01f 100644 --- a/emacs/test-flan.el +++ b/emacs/test-flan.el @@ -545,7 +545,7 @@ already rely on it — so nothing here is a stand-in for the real thing." "/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\n") + (flan--append-output "said hi\nscore: 10\n") (font-lock-ensure) (let ((face-on (lambda (text) (goto-char (point-min)) @@ -559,6 +559,12 @@ already rely on it — so nothing here is a stand-in for the real thing." (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:"))))) diff --git a/lib/check.ml b/lib/check.ml index e75979b1..d601138c 100644 --- a/lib/check.ml +++ b/lib/check.ml @@ -4252,7 +4252,17 @@ let rec check ctx ?want (e : Ast.expr) : Tast.expr = if is_poison r then env.poison <- env.poison + 1; r | exception Loc.Error d -> - if not (caused ()) then record_recovered env 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 @@ -4263,6 +4273,20 @@ let rec check ctx ?want (e : Ast.expr) : Tast.expr = 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; @@ -10861,6 +10885,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 -> diff --git a/lib/dev.ml b/lib/dev.ml index 1570302c..c71660f7 100644 --- a/lib/dev.ml +++ b/lib/dev.ml @@ -1246,6 +1246,18 @@ let eval_expr_at t ~code ~origin ~pause ~at = TODO.org, "Whose break it is, which no counter answers" has it. *) 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 @@ -1417,6 +1429,9 @@ let eval_expr_at t ~code ~origin ~pause ~at = | 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); @@ -1481,6 +1496,7 @@ let eval_expr_at t ~code ~origin ~pause ~at = 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 @@ -2425,7 +2441,7 @@ let stopped_frame t ~frame ~what : (string * Tast.fn, string) result = 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 t ~code ~origin ~pause = +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 -> @@ -2438,7 +2454,17 @@ let eval_expr ?frame t ~code ~origin ~pause = "the program resumed while this was being asked; there is no frame \ to evaluate in any more" | Some gen -> - (match bound_slots t ~frame:index with + (* 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 -> @@ -4444,7 +4470,8 @@ and handle_op t req = | Some { Form.v = Form.Sym "nil"; _ } | None -> false | Some _ -> true in - eval_expr ?frame:(Wire.int_field req "frame") 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 @@ -5229,19 +5256,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 diff --git a/test/test_dev.ml b/test/test_dev.ml index ba666e10..1dada954 100644 --- a/test/test_dev.ml +++ b/test/test_dev.ml @@ -127,6 +127,111 @@ 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 @@ -168,9 +273,19 @@ let eval_in_frame_checks ~backend ask = | 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 + (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 ─────────────── *) @@ -239,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 @@ -4418,6 +4547,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 @@ -4882,6 +5012,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 @@ -4927,6 +5064,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 @@ -8799,135 +8937,6 @@ let () = hook_block ~llvm:false; hook_block ~llvm:true; - (* ── The stepper ───────────────────────────────────────────────── - [dev-pause.flan] calls [step] every 5ms. Sent with [:step t], a call - stops before each form of its body: first the (set ...), then, after - [next], the [ticks] it answers. [continue] runs the rest of the call, - and the next call steps again. A plain evaluation takes it out. Under - both backends, each with its own daemon. *) - let stepper ~llvm = - let what = if llvm then "llvm " else "x86 " in - let ssock = tmp (what ^ "step.sock") and sout = tmp (what ^ "step.out") in - (try Sys.remove ssock with Sys_error _ -> ()); - let sfd = Unix.openfile sout [ Unix.O_WRONLY; Unix.O_CREAT; Unix.O_TRUNC ] 0o600 in - let spid = - Unix.create_process flan - (Array.append - [| flan; "dev"; "programs/dev-pause.flan"; "-s"; ssock |] - (if llvm then [| "--llvm" |] else [||])) - Unix.stdin sfd Unix.stderr - in - Unix.close sfd; - if not (listening ~pid:spid ssock) then - fail "%sstepper daemon %s" what !listen_why - else begin - let c = connect ssock in - let ask = request c in - 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; - (try Unix.close c with Unix.Unix_error _ -> ()) - end; - (try Unix.kill spid Sys.sigkill with Unix.Unix_error _ -> ()); - (try ignore (Unix.waitpid [] spid) with Unix.Unix_error _ -> ()); - List.iter (fun f -> try Sys.remove f with Sys_error _ -> ()) [ ssock; sout ] - in - stepper ~llvm:false; - stepper ~llvm:true; List.iter (fun f -> try Sys.remove f with Sys_error _ -> ()) [ sock; out; bsock; bout ]; diff --git a/test/test_session.ml b/test/test_session.ml index e152b4c5..8fe132ae 100644 --- a/test/test_session.ml +++ b/test/test_session.ml @@ -1795,6 +1795,24 @@ let () = 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 From 2c8bd61a204f605778525c0baaa197caacfe3d59 Mon Sep 17 00:00:00 2001 From: Joseph Ferano Date: Fri, 25 Sep 2026 16:48:09 +0700 Subject: [PATCH 31/42] (free s) hands a slice (bytes s) or (clone xs) made back to the context allocator or a named one, a dev build traps on the wrong allocator, and a sliced array literal lives for its whole function on x86 --- docs/BUILT.md | 2 +- lib/check.ml | 87 +++++++++++++++++++++++++++-------- lib/emit.ml | 1 + runtime/flan_dev.c | 34 ++++++++++++++ runtime/flan_rt.c | 41 ++++++++++++++++- test/programs/bytes-copy.flan | 14 +++++- test/programs/free-slice.flan | 26 +++++++++++ test/test_acceptance.ml | 31 ++++++++++++- test/test_flan.ml | 10 ++-- web/index.html | 6 ++- 10 files changed, 221 insertions(+), 31 deletions(-) create mode 100644 test/programs/free-slice.flan diff --git a/docs/BUILT.md b/docs/BUILT.md index 3ded16d5..3ae6cf4c 100644 --- a/docs/BUILT.md +++ b/docs/BUILT.md @@ -3000,7 +3000,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 diff --git a/lib/check.ml b/lib/check.ml index 9ca97cf7..2dcb4981 100644 --- a/lib/check.ml +++ b/lib/check.ml @@ -8286,8 +8286,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 @@ -9232,9 +9233,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,11 +9284,41 @@ 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)) (* (clone v) uses the current allocator, (clone v a) names one. A deep, independent copy: spec-memory.md's "copying is always explicit". *) @@ -10070,12 +10110,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 +10194,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 @@ -11867,14 +11914,16 @@ 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."); @@ -11982,8 +12031,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 \ diff --git a/lib/emit.ml b/lib/emit.ml index edd3773a..afb5de69 100644 --- a/lib/emit.ml +++ b/lib/emit.ml @@ -4913,6 +4913,7 @@ 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) diff --git a/runtime/flan_dev.c b/runtime/flan_dev.c index 245541a0..39769663 100644 --- a/runtime/flan_dev.c +++ b/runtime/flan_dev.c @@ -1213,6 +1213,10 @@ 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; } flan_reg_entry; /* ── Why this table has a seqlock and the watch table's is the model ─── @@ -1505,6 +1509,7 @@ 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; flan_reg_end(e); flan_reg_used++; break; @@ -1518,8 +1523,18 @@ 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. */ +void flan_dev_reg_note_owned(void *base, int64_t bytes, int64_t elem, + const char *type, int64_t typelen, + const void *owner); + void flan_dev_reg_note(void *base, int64_t bytes, int64_t elem, const char *type, int64_t typelen) { + flan_dev_reg_note_owned(base, bytes, elem, type, typelen, NULL); +} + +void flan_dev_reg_note_owned(void *base, int64_t bytes, int64_t elem, + const char *type, int64_t typelen, + const void *owner) { uintptr_t a = (uintptr_t)base; size_t s; int64_t probe; @@ -1549,6 +1564,7 @@ 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_end(&flan_reg[j]); return; } @@ -1575,6 +1591,24 @@ 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, 3 when it was already released. */ +static flan_reg_entry *flan_reg_find(uintptr_t a); + +int32_t flan_dev_reg_owner_check(const void *p, const void *owner) { + 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->owner != NULL && e->owner != 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..df531bde 100644 --- a/runtime/flan_rt.c +++ b/runtime/flan_rt.c @@ -1677,6 +1677,10 @@ 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); 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 +2485,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_owned(q, len, 1, "u8", 2, a); out->ptr = q; out->len = len; return 1; @@ -2733,6 +2737,38 @@ 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 == 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" + : "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); + why = flan_dev_reg_owner_check(p, a); + 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) { @@ -3662,7 +3698,8 @@ int8_t flan_map_clone(flan_map *dst, flan_map *src, flan_allocator *a, 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/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/free-slice.flan b/test/programs/free-slice.flan new file mode 100644 index 00000000..580e0fa1 --- /dev/null +++ b/test/programs/free-slice.flan @@ -0,0 +1,26 @@ +;;;; (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. +(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)) + :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/test_acceptance.ml b/test/test_acceptance.ml index 19a2ae4a..468381ca 100644 --- a/test/test_acceptance.ml +++ b/test/test_acceptance.ml @@ -881,7 +881,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 +889,35 @@ 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", 11, "came from another allocator"); + ("2", 12, "was already freed"); + ("3", 15, "not a block an allocator handed out") ]; + (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 diff --git a/test/test_flan.ml b/test/test_flan.ml index 4d0f57f7..b7599ca7 100644 --- a/test/test_flan.ml +++ b/test/test_flan.ml @@ -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 diff --git a/web/index.html b/web/index.html index 7d1df1ee..862104c5 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 From 9d0d42e4676536119c4eb754fc0e1ba8de564421 Mon Sep 17 00:00:00 2001 From: Joseph Ferano Date: Fri, 25 Sep 2026 16:59:11 +0700 Subject: [PATCH 32/42] A generic struct's copy prints as (Pair i32 {...}), crosses to C behind a pointer, names each use that made it when refused, settles literal fields at the wider type, and is laid out by stores and restarts that first name it --- lib/check.ml | 93 ++++++++++++++++++++--- lib/dev.ml | 12 ++- lib/parse.ml | 50 ++++++++++--- lib/render.ml | 2 +- lib/session.ml | 29 +++++--- lib/shim.ml | 118 ++++++++++++++++++++++++++++++ lib/types.ml | 9 +++ test/programs/generic-struct.flan | 3 +- test/test_acceptance.ml | 33 ++++++++- test/test_dev.ml | 22 ++++++ test/test_flan.ml | 41 ++++++++++- test/test_session.ml | 50 +++++++++++++ 12 files changed, 422 insertions(+), 40 deletions(-) diff --git a/lib/check.ml b/lib/check.ml index c9c6a0df..8efdae6b 100644 --- a/lib/check.ml +++ b/lib/check.ml @@ -79,6 +79,16 @@ 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 @@ -1642,7 +1652,17 @@ and struct_copy env loc name targs = restore (); Hashtbl.remove env.copies key; Hashtbl.remove env.structs key; - raise e + (* 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 -> + 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? *) @@ -1728,12 +1748,12 @@ and resolve_name env ~seen loc 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 @@ -1769,7 +1789,15 @@ and resolve_name env ~seen loc n = ~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 - (String.concat " " (List.map (fun (p, _) -> "$" ^ p) g.gparams)) + (* 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. @@ -4056,7 +4084,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" @@ -6611,12 +6639,37 @@ and generic_ctor ctx ~want loc name given = | 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 List.iter (fun ((f : Tast.field), (a : Ast.expr)) -> + match f.Tast.fty with + | 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 @@ -6657,7 +6710,13 @@ and generic_ctor ctx ~want loc name given = "%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, _) -> "$" ^ q) g.gparams))) + (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) @@ -11946,7 +12005,7 @@ 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 (open_ty t) && not (pred_holds p.Ast.pname t) -> @@ -12064,17 +12123,29 @@ and instantiate env loc gname vars subst cparams cret = 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. In its body: %s" - gname (at ()) d.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 - "the refusal is here, in the prelude" ]; + @ [ Loc.note d.Loc.dloc ("in the prelude, " ^ reason) ]; expansion = None }) | Loc.Error d when d.Loc.dloc <> loc -> Loc.Error diff --git a/lib/dev.ml b/lib/dev.ml index f4982178..c5649835 100644 --- a/lib/dev.ml +++ b/lib/dev.ml @@ -1920,13 +1920,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 diff --git a/lib/parse.ml b/lib/parse.ml index 6263645a..e8e84523 100644 --- a/lib/parse.ml +++ b/lib/parse.ml @@ -73,6 +73,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,23 +145,41 @@ 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 <> [] -> + | 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 = - 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 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 with - | Int n when capitalised -> { Ast.t = Ast.Tlen n; tloc = a.loc } + 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)) diff --git a/lib/render.ml b/lib/render.ml index c5cf9f6d..1f16802c 100644 --- a/lib/render.ml +++ b/lib/render.ml @@ -333,7 +333,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 ("(" ^ Types.struct_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 ac732970..fff0f656 100644 --- a/lib/session.ml +++ b/lib/session.ml @@ -1543,7 +1543,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 +1655,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 +1916,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 +2233,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 +2270,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 +2291,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 +2365,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 +2406,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 +2454,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 []; @@ -2564,7 +2575,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 []; diff --git a/lib/shim.ml b/lib/shim.ml index bbcdd7be..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 @@ -269,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) @@ -546,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/types.ml b/lib/types.ml index 328909f9..a6f25857 100644 --- a/lib/types.ml +++ b/lib/types.ml @@ -229,6 +229,15 @@ let rec equal a b = 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 diff --git a/test/programs/generic-struct.flan b/test/programs/generic-struct.flan index f080c4e4..f295fbd8 100644 --- a/test/programs/generic-struct.flan +++ b/test/programs/generic-struct.flan @@ -83,7 +83,8 @@ (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 (.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)))] diff --git a/test/test_acceptance.ml b/test/test_acceptance.ml index 04ef62d0..005df81a 100644 --- a/test/test_acceptance.ml +++ b/test/test_acceptance.ml @@ -3471,7 +3471,8 @@ let () = 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\n6\n\ + "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; @@ -4229,6 +4230,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 diff --git a/test/test_dev.ml b/test/test_dev.ml index fa86db9c..926c1971 100644 --- a/test/test_dev.ml +++ b/test/test_dev.ml @@ -628,6 +628,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 diff --git a/test/test_flan.ml b/test/test_flan.ml index 1ab6d401..ed62a56b 100644 --- a/test/test_flan.ml +++ b/test/test_flan.ml @@ -6044,6 +6044,7 @@ let () = 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)); @@ -6720,13 +6721,13 @@ 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. *) @@ -6795,6 +6796,40 @@ let () = (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))"; diff --git a/test/test_session.ml b/test/test_session.ml index 73ff7f35..9f206aa6 100644 --- a/test/test_session.ml +++ b/test/test_session.ml @@ -374,6 +374,56 @@ let () = | 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 From 1e8086b4d3539f916d49b3989fd4692dbfa23af8 Mon Sep 17 00:00:00 2001 From: Joseph Ferano Date: Fri, 25 Sep 2026 17:00:16 +0700 Subject: [PATCH 33/42] The use-after-release checks to build are recorded --- TODO.org | 1 + 1 file changed, 1 insertion(+) diff --git a/TODO.org b/TODO.org index a1fd604d..867e46b1 100644 --- a/TODO.org +++ b/TODO.org @@ -905,6 +905,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 From 7bcf9e5054d9a3e70f56054040cff39d992c3577 Mon Sep 17 00:00:00 2001 From: Joseph Ferano Date: Fri, 25 Sep 2026 17:04:52 +0700 Subject: [PATCH 34/42] A dev build refuses (free s) on a slice over a Vec's or a Map's storage, and says a formatted number's text is released by free-temp --- lib/check.ml | 2 +- lib/emit.ml | 1 + runtime/flan_dev.c | 40 +++++++++++++++++++++++++++++------ runtime/flan_rt.c | 36 +++++++++++++++++++++++++------ test/programs/free-slice.flan | 11 +++++++++- test/test_acceptance.ml | 8 ++++--- 6 files changed, 80 insertions(+), 18 deletions(-) diff --git a/lib/check.ml b/lib/check.ml index 50f22cd7..f0c7d623 100644 --- a/lib/check.ml +++ b/lib/check.ml @@ -8482,7 +8482,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; diff --git a/lib/emit.ml b/lib/emit.ml index ca47898d..4752a78d 100644 --- a/lib/emit.ml +++ b/lib/emit.ml @@ -5037,6 +5037,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) diff --git a/runtime/flan_dev.c b/runtime/flan_dev.c index 16906183..e096961d 100644 --- a/runtime/flan_dev.c +++ b/runtime/flan_dev.c @@ -1267,6 +1267,10 @@ typedef struct { * 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 ─── @@ -1560,6 +1564,7 @@ static void flan_reg_compact(void) { 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; @@ -1573,18 +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. */ -void flan_dev_reg_note_owned(void *base, int64_t bytes, int64_t elem, - const char *type, int64_t typelen, - const void *owner); +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_dev_reg_note_owned(base, bytes, elem, type, typelen, NULL); + 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; @@ -1615,6 +1633,7 @@ void flan_dev_reg_note_owned(void *base, int64_t bytes, int64_t 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; } @@ -1645,17 +1664,24 @@ int flan_dev_reg_overflowed(void) { return flan_reg_full; } * 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, 3 when it was already released. */ + * 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) { +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->owner != NULL && e->owner != owner) return 2; + if (!e->sliced) return 4; + if (e->owner != NULL && e->owner != owner) { + if (found) *found = e->owner; + return 2; + } return 0; } diff --git a/runtime/flan_rt.c b/runtime/flan_rt.c index df531bde..2a500f0f 100644 --- a/runtime/flan_rt.c +++ b/runtime/flan_rt.c @@ -1680,7 +1680,11 @@ void flan_dev_reg_note(void *base, int64_t bytes, int64_t elem, 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); +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 @@ -2485,7 +2489,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_owned(q, len, 1, "u8", 2, a); + flan_dev_reg_note_sliced(q, len, 1, "u8", 2, a); out->ptr = q; out->len = len; return 1; @@ -2748,9 +2752,14 @@ _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 == 2 ? "this slice's block came from another allocator — free it " - "through the allocator it was made with, (free s a)" + 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); @@ -2762,8 +2771,15 @@ void flan_slice_free(const void *p, int64_t n, int64_t size, int64_t align, int64_t bytes; if (p == NULL || n <= 0) return; if (!a) flan_null_alloc_fail(loc, loclen); - why = flan_dev_reg_owner_check(p, a); - if (why != 0) flan_slice_free_fail(loc, loclen, why); + { + 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); @@ -3696,6 +3712,14 @@ 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_owned(v->ptr, v->cap * size, size, type, typelen, diff --git a/test/programs/free-slice.flan b/test/programs/free-slice.flan index 580e0fa1..537c91f7 100644 --- a/test/programs/free-slice.flan +++ b/test/programs/free-slice.flan @@ -3,7 +3,9 @@ ;;;; 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. +;;;; 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)] @@ -13,6 +15,13 @@ (= 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) diff --git a/test/test_acceptance.ml b/test/test_acceptance.ml index 468381ca..8b2db4ec 100644 --- a/test/test_acceptance.ml +++ b/test/test_acceptance.ml @@ -913,9 +913,11 @@ let () = "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", 11, "came from another allocator"); - ("2", 12, "was already freed"); - ("3", 15, "not a block an allocator handed out") ]; + [ ("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 From 20684c2d9f6fd63ca2484e902c03a02b551e6e3b Mon Sep 17 00:00:00 2001 From: Joseph Ferano Date: Fri, 25 Sep 2026 17:06:19 +0700 Subject: [PATCH 35/42] A grown parameter the function returns, or whose field it reassigns, is not warned at --- lib/check.ml | 77 ++++++++++++++++++++++++++++++++++++++++++++++- test/test_flan.ml | 16 ++++++++++ 2 files changed, 92 insertions(+), 1 deletion(-) diff --git a/lib/check.ml b/lib/check.ml index 2cfcbaad..616992ec 100644 --- a/lib/check.ml +++ b/lib/check.ml @@ -13317,6 +13317,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 @@ -13339,6 +13388,7 @@ 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, @@ -13347,7 +13397,32 @@ let rec check_fn env (fn : Ast.fn) : Tast.fn = Option.map (fun b -> (b.slot, p)) (List.assoc_opt p.Ast.fname ctx.scope)) fn.Ast.params ) :: grow_saved; - Fun.protect ~finally:(fun () -> grow_params := grow_saved) @@ fun () -> + 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 | [] -> diff --git a/test/test_flan.ml b/test/test_flan.ml index f0b689f6..fa7c57ab 100644 --- a/test/test_flan.ml +++ b/test/test_flan.ml @@ -5915,6 +5915,22 @@ let () = | 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)))" From d6e6a5dc0c91a95bf46afe4adfa6f59f3b43ed3d Mon Sep 17 00:00:00 2001 From: Joseph Ferano Date: Fri, 25 Sep 2026 17:12:05 +0700 Subject: [PATCH 36/42] A program's global named as a prelude function or global shadows it for the file, with the shadowing warning a defn gets --- lib/check.ml | 23 +++++++++++++++-------- test/programs/shadow-prelude-global.flan | 14 ++++++++++++++ test/test_acceptance.ml | 5 +++++ test/test_flan.ml | 14 ++++++++++++++ 4 files changed, 48 insertions(+), 8 deletions(-) create mode 100644 test/programs/shadow-prelude-global.flan diff --git a/lib/check.ml b/lib/check.ml index 616992ec..d2193bb4 100644 --- a/lib/check.ml +++ b/lib/check.ml @@ -14543,30 +14543,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)) -> 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/test_acceptance.ml b/test/test_acceptance.ml index 214f522e..4080d400 100644 --- a/test/test_acceptance.ml +++ b/test/test_acceptance.ml @@ -592,6 +592,11 @@ let () = 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\ diff --git a/test/test_flan.ml b/test/test_flan.ml index fa7c57ab..836e7166 100644 --- a/test/test_flan.ml +++ b/test/test_flan.ml @@ -5953,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. From ff8b61e44ce8212e558e758c06418a4163e75d07 Mon Sep 17 00:00:00 2001 From: Joseph Ferano Date: Fri, 25 Sep 2026 19:57:58 +0700 Subject: [PATCH 37/42] A self-containing or runaway generic struct and a where clause over a length are each one error among the file's others, and a literal that does not fit a variable a typed field decided names that field --- lib/check.ml | 102 +++++++++++++++++++++++++++++++++++++++++----- test/test_flan.ml | 41 +++++++++++++++++++ 2 files changed, 133 insertions(+), 10 deletions(-) diff --git a/lib/check.ml b/lib/check.ml index 25f7018e..670a5f8d 100644 --- a/lib/check.ml +++ b/lib/check.ml @@ -251,6 +251,15 @@ type env = { (* 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; @@ -329,6 +338,8 @@ let new_env () = { 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; @@ -343,6 +354,13 @@ let new_env () = { 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 @@ -1599,9 +1617,14 @@ and struct_len_arg env name p (a : Ast.texpr) = (* The copy of generic struct [name] at [targs], made on first use and registered as an ordinary struct under its key. *) -and struct_copy env loc name targs = +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 @@ -1673,7 +1696,7 @@ and struct_copy env loc name targs = (* 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 -> + | Loc.Error d when d.Loc.dloc <> loc && not at_definition -> Loc.raise_diag { d with Loc.notes = @@ -6810,9 +6833,37 @@ and generic_ctor ctx ~want loc name given = 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 @@ -6841,7 +6892,14 @@ and generic_ctor ctx ~want loc name given = nothing. *) | None -> Option.iter (fun d -> unsure := d :: !unsure) refusal | Some t -> - if not (bind_ty subst f.Tast.fty t) then + 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)) @@ -13370,9 +13428,14 @@ let collect env (decls : Ast.decl list) = 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 - ignore - (struct_copy env loc n - (List.map (fun (p, _) -> Types.Var p) g.gparams)) + (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 @@ -13517,10 +13580,22 @@ let collect env (decls : Ast.decl list) = an open question in TODO.org, not an accident to fall out of this. *) if List.mem p.Ast.pvar lens then - Loc.failk "check/length-predicate" p.Ast.ploc - "$%s is a length, and a where clause takes type predicates \ - only — %s is about a type" p.Ast.pvar p.Ast.pname) + 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; @@ -13623,7 +13698,10 @@ let collect env (decls : Ast.decl list) = out or a zero value is built for it — which would not fail, it would hang. *) let check_finite env = let walk _ n = finite_from env n in - Hashtbl.iter (fun n _ -> walk [] n) env.structs; + (* 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 @@ -14978,10 +15056,14 @@ 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 []; let decls = collect env decls in 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 diff --git a/test/test_flan.ml b/test/test_flan.ml index ed62a56b..6aca6d1e 100644 --- a/test/test_flan.ml +++ b/test/test_flan.ml @@ -6017,6 +6017,47 @@ let () = = [ "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 From df00848910234e2c638c4319b91972d6bf8ef4f8 Mon Sep 17 00:00:00 2001 From: Joseph Ferano Date: Fri, 25 Sep 2026 20:00:51 +0700 Subject: [PATCH 38/42] A struct value's printed head comes from Render.head, which every renderer shares --- lib/render.ml | 8 +++++++- 1 file changed, 7 insertions(+), 1 deletion(-) diff --git a/lib/render.ml b/lib/render.ml index 1f16802c..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 ("(" ^ Types.struct_head 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 From 5d3a0fc316d1ea1eacd2f1fc139f3941eec445af Mon Sep 17 00:00:00 2001 From: Joseph Ferano Date: Fri, 25 Sep 2026 20:14:22 +0700 Subject: [PATCH 39/42] Inferring a closure return and recompiling a _ caller after its callee changes wait behind .fln --- TODO.org | 9 +++++++++ 1 file changed, 9 insertions(+) diff --git a/TODO.org b/TODO.org index 91b6fb73..87fae9fa 100644 --- a/TODO.org +++ b/TODO.org @@ -637,6 +637,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 @@ -1426,6 +1430,11 @@ out the first element typing the rest. * Dev loop +** 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 host's cell for that name, so the prelude's calls compiled into the host follow it; From e7d82cb64031c49c9f6b5d0aef904649a7b2283b Mon Sep 17 00:00:00 2001 From: Joseph Ferano Date: Fri, 25 Sep 2026 20:30:31 +0700 Subject: [PATCH 40/42] A match arm can match a number or string literal, queued --- TODO.org | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/TODO.org b/TODO.org index 87fae9fa..262eec92 100644 --- a/TODO.org +++ b/TODO.org @@ -296,6 +296,10 @@ 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. +** 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 From 25911d7c9d70703ed9633cdb1fb1da0dcec0fab2 Mon Sep 17 00:00:00 2001 From: Joseph Ferano Date: Fri, 25 Sep 2026 20:31:57 +0700 Subject: [PATCH 41/42] Nested ML-style patterns are wanted --- TODO.org | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/TODO.org b/TODO.org index 262eec92..cee24e7a 100644 --- a/TODO.org +++ b/TODO.org @@ -296,6 +296,10 @@ 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. +** TODO ML-style patterns +Wanted: nested destructuring (data cases, structs, arrays, slices), guards, or-patterns, +literals at any depth, and exhaustiveness checked over the nesting. Needs a design pass. + ** 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. From db7f703c0e4fdeeb6f1e16f11cd838eca276ea65 Mon Sep 17 00:00:00 2001 From: Joseph Ferano Date: Fri, 25 Sep 2026 20:33:26 +0700 Subject: [PATCH 42/42] ML-style patterns are held as a future direction --- TODO.org | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/TODO.org b/TODO.org index cee24e7a..45c6a7bc 100644 --- a/TODO.org +++ b/TODO.org @@ -296,9 +296,9 @@ 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. -** TODO ML-style patterns -Wanted: nested destructuring (data cases, structs, arrays, slices), guards, or-patterns, -literals at any depth, and exhaustiveness checked over the nesting. Needs a design pass. +** 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

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?