Merge branch 'master' into worktree-agent-adcfc27e0ceac8df4

This commit is contained in:
Joseph Ferano 2026-09-25 12:55:56 +07:00
commit e7b01ea01c
8 changed files with 674 additions and 52 deletions

View File

@ -1078,6 +1078,10 @@ should not pay for identity and metadata. Not implemented.
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";
@ -1086,11 +1090,16 @@ An unknown call whose near miss is a value — =(context-allocator)= against
=context/allocator=, or a global — says the name is a value written without
parentheses, and names no call at all when the call had arguments.
** NEXT (max-of T) and (min-of T)
** NEXT (max-value T) and (min-value T)
Decided 2026-09-25: the type-limit constants as a form taking a type, Odin's
max(T), valid at any numeric type or a numeric?-bounded variable. For a float,
min-of is the most negative finite value.
** NEXT (Ptr const T), the pointer beside [const T]
Decided 2026-09-25: addr through a read-only slice gives a (Ptr const T), which
nothing writes through; (Ptr T) widens to it and never back; a C parameter
declared const T* takes one. Closes the addr hole in [const T].
* Backends
** DONE The x86 backend tracks LLVM at -O0
@ -1270,6 +1279,13 @@ lowering buffer annotates all four sections, the two =llc= ones from a =--debug=
copy of the IR. Rules out writing a disassembler, and reading the source off disk
at disassembly time.
** NEXT A temporary allocator, wiped each frame
Decided 2026-09-25: Odin's context.temp_allocator. i64->bytes, f64->bytes and
other quick formatting allocate from it, so a number drawn every frame no longer
leaks from the default allocator. A dev build wipes it at each frame boundary;
otherwise the program calls (free-temp) once per frame. Text kept past the frame
is cloned.
* Runtime
** DONE An index out of range is a condition
@ -1931,6 +1947,11 @@ C-x C-e thunk triggered. Needs reproducing under load and fixing.
* Editor
** TODO C-c C-l on a generic needs a session to find its copies
The lowering view compiles the file, but only the daemon's =defs= says which
functions are a generic's copies, so with no session a generic's name shows
nothing. Needs a way to ask the compiler for a file's copies of a name.
** DONE The syntax table and the font-lock lists are read off the parser
CLOSED: [2026-09-21]
The special-form list is the heads the parser dispatches on, the builtin list is

View File

@ -415,6 +415,40 @@ looks like."
(buffer-substring-no-properties beg (line-beginning-position 2))
(buffer-substring-no-properties beg (point-max)))))))
(defun flan-lower--copies (name)
"The names of the copies of generic NAME the connected program has, or nil.
A generic has no code under its own name: each type it is called at makes a
copy named for the types, `selection-sort-i32'. The daemon lists the generic
with its signature as written, `$' and all, and lists each copy with the
generic's own location -- which is what tells a copy from an unrelated
function that happens to share the prefix, `sort-bytes' beside `sort'."
(let ((g (assoc name flan--defs)))
(when (and g (string-match-p "\\$" (nth 2 g)))
(let ((prefix (concat name "-")))
(sort (mapcar #'car
(seq-filter
(lambda (d)
(and (string-prefix-p prefix (car d))
(equal (nth 1 d) "fn")
(equal (nth 3 d) (nth 3 g))))
flan--defs))
#'string<)))))
(defun flan-lower--fetch-copies (section name)
"SECTION for each copy of generic NAME, each under a line naming it, or nil.
The copies are the session's, and the file may call the generic at fewer
types than the session does; a copy the file does not make is named as such
rather than left out."
(let ((copies (flan-lower--copies name)))
(and copies
(mapconcat
(lambda (c)
(format ";; %s\n%s" c
(or (funcall flan-lower-fetch-function
section flan-lower--file c flan-lower--flags)
"not made by this file: nothing in it calls at these types\n")))
copies "\n"))))
(defun flan-lower--gather (sections)
"Fetch each of SECTIONS into `flan-lower--texts', replacing what was there.
One section's failure is that section's text and not the buffer's: `llc' can
@ -425,6 +459,7 @@ altogether would be the wrong answer to that."
(or (funcall flan-lower-fetch-function
s flan-lower--file flan-lower--name
flan-lower--flags)
(flan-lower--fetch-copies s flan-lower--name)
(format "nothing for `%s' here\n" flan-lower--name))
(error (concat (error-message-string err) "\n")))))
(setf (alist-get s flan-lower--texts) text))))

View File

@ -3029,36 +3029,72 @@ tail of exactly one packaged name, because a buffer inside a package writes
(let ((inhibit-read-only t))
(erase-buffer)
(flan-disassembly-mode)
(let ((start (point)))
(insert (format "; %s for %s\n"
(if ir "LLVM IR" "disassembly") full))
(put-text-property start (point) 'face 'font-lock-comment-face))
(flan-disassemble--header "signature" (plist-get r :signature))
(flan-disassemble--header "source" (plist-get r :loc))
(flan-disassemble--header
"generation"
(let ((g (plist-get r :generation)))
(if (and (numberp g) (zerop g))
"0 (the build the program was launched from)"
(format "%s" g))))
(flan-disassemble--header "object" (plist-get r :object))
(flan-disassemble--header "showing" (plist-get r :basis))
(when (plist-get r :note)
(flan-disassemble--header "note" (plist-get r :note)))
(insert "\n")
(let ((start (point)))
(insert (plist-get r :text))
;; The source lines the daemon placed in the listing, and the
;; headings in the IR, are `;' comments; shown as comments so the
;; code between them reads as the code.
(save-excursion
(goto-char start)
(while (re-search-forward "^[ \t]*;.*$" nil t)
(put-text-property (match-beginning 0) (match-end 0)
'face 'font-lock-comment-face))))
(flan-disassemble--render r (if ir "LLVM IR" "disassembly"))
(goto-char (point-min))))
(display-buffer flan-disassembly-buffer)))
(defun flan-disassemble--comment (text)
"Insert TEXT as a line drawn as a comment."
(let ((start (point)))
(insert text "\n")
(put-text-property start (point) 'face 'font-lock-comment-face)))
(defun flan-disassemble--render (r what)
"Insert the reply R into the current buffer; WHAT names the view.
A generic has no code of its own, only a copy per type it was called at.
The daemon answers its name with that copy's listing when there is one, and
with `:copies', one listing each, when there are several; each is headed by
the types its variables were bound to."
(let ((copies (plist-get r :copies)))
(if copies
(progn
(flan-disassemble--comment
(format "; %s for %s, one copy per type it is called at"
what (plist-get r :name)))
(flan-disassemble--header "signature" (plist-get r :signature))
(dolist (c copies)
(insert "\n")
(flan-disassemble--comment
(format ";; %s at %s" (plist-get c :generic) (plist-get c :types)))
(if (plist-get c :refused)
(progn
(flan-disassemble--header "signature" (plist-get c :signature))
(flan-disassemble--header "no listing" (plist-get c :refused)))
(flan-disassemble--listing c))))
(flan-disassemble--comment
(if (plist-get r :generic)
(format "; %s for %s at %s" what (plist-get r :generic)
(plist-get r :types))
(format "; %s for %s" what (plist-get r :name))))
(flan-disassemble--listing r))))
(defun flan-disassemble--listing (r)
"Insert one function's headers and listing out of the reply R."
(flan-disassemble--header "signature" (plist-get r :signature))
(flan-disassemble--header "source" (plist-get r :loc))
(flan-disassemble--header
"generation"
(let ((g (plist-get r :generation)))
(if (and (numberp g) (zerop g))
"0 (the build the program was launched from)"
(format "%s" g))))
(flan-disassemble--header "object" (plist-get r :object))
(flan-disassemble--header "showing" (plist-get r :basis))
(when (plist-get r :note)
(flan-disassemble--header "note" (plist-get r :note)))
(insert "\n")
(let ((start (point)))
(insert (plist-get r :text))
(unless (bolp) (insert "\n"))
;; The source lines the daemon placed in the listing, and the headings in
;; the IR, are `;' comments; shown as comments so the code between them
;; reads as the code.
(save-excursion
(goto-char start)
(while (re-search-forward "^[ \t]*;.*$" nil t)
(put-text-property (match-beginning 0) (match-end 0)
'face 'font-lock-comment-face)))))
;;;###autoload
(defun flan-disassemble-ir (name)
"Show the LLVM IR NAME's installed body was built from.

View File

@ -1822,6 +1822,44 @@ already rely on it — so nothing here is a stand-in for the real thing."
(user-error (setq raised (error-message-string err))))
(and raised (string-match-p "not a function" raised))))
;; A generic has no code under its own name, only a copy per type it is
;; called at, so its name is answered with those: refused while there are
;; none, and one listing per copy, each headed by its types, once there
;; are several. Sent from a file that is not the program's.
(let ((file (concat socket3 "-sorts.flan")))
(flan--request
(list :op "eval" :file file
:code "(defn selection-sort [xs [$t]] ()
{:where (ordered? $t)}
(dotimes [i (length xs)]
(let [m i]
(dotimes [j (length xs)]
(when (< (at xs j) (at xs m)) (set m j)))
(swap xs i m))))"))
(test-flan--check "a generic nothing calls yet is refused, saying why"
(let ((raised nil))
(condition-case err (flan-disassemble "selection-sort" t)
(user-error (setq raised (error-message-string err))))
(and raised
(string-match-p "is generic" raised)
(string-match-p "no code has been made" raised))))
(flan--request
(list :op "eval" :file file
:code "(defn use-sort [] ()
(let [a [3 1 2]] (selection-sort (slice a 0 3)))
(let [b [3.0 1.0]] (selection-sort (slice b 0 2))))"))
(flan-disassemble "selection-sort" t)
(with-current-buffer flan-disassembly-buffer
(let ((text (buffer-string)))
(test-flan--check "a generic's IR is shown copy by copy"
(and (string-match-p "\\`; LLVM IR for selection-sort, one copy" text)
(string-match-p "^;; selection-sort at \\$t = i32$" text)
(string-match-p "^;; selection-sort at \\$t = f64$" text)
(string-match-p "^define .*flan\\.selection-sort-i32" text)
(string-match-p "^define .*flan\\.selection-sort-f64" text)))
(test-flan--check "each copy names the file the generic was sent from"
(string-match-p (regexp-quote file) text)))))
(flan-quit)
(ignore-errors (delete-file socket3)))
@ -1841,6 +1879,30 @@ already rely on it — so nothing here is a stand-in for the real thing."
;; anything being shut at all. `invisible-p' is the predicate that means
;; what it says, and it means it whether outline folded with an overlay or
;; with a text property.
;;
;; A generic is compiled only as its copies, so its own name finds nothing
;; and each copy is shown under a line naming it. A function that merely
;; shares the prefix and was written elsewhere is not a copy.
(with-temp-buffer
(let ((flan--defs
'(("sort" "fn" "sort [[$t]] ()" "<prelude>:331:7" "")
("sort-i32" "fn" "sort-i32 [[i32]] ()" "<prelude>:331:7" "")
("sort-f64" "fn" "sort-f64 [[f64]] ()" "<prelude>:331:7" "")
("sort-bytes" "fn" "sort-bytes [[[u8]]] ()" "<prelude>:1595:7" "")))
(flan-lower-fetch-function
(lambda (section _file name _flags)
(unless (equal name "sort") (format "%s of %s\n" section name))))
(flan-lower--file "x.flan")
(flan-lower--name "sort")
(flan-lower--flags nil)
(flan-lower--texts nil))
(flan-lower--gather '(ir))
(let ((text (alist-get 'ir flan-lower--texts)))
(test-flan--check "a generic's lowering is each of its copies, named"
(and (string-match-p "^;; sort-f64\nir of sort-f64$" text)
(string-match-p "^;; sort-i32\nir of sort-i32$" text)
(not (string-match-p "sort-bytes" text)))))))
(let* ((flan-lower--state (copy-alist flan-lower--state))
(flan-lower-fetch-function
(lambda (section _file name _flags)

View File

@ -407,6 +407,37 @@ let spell_arg stand_for (a : Ast.expr) =
| Ast.UInt (_, s) -> s
| _ -> stand_for
(* Operators other languages spell differently, each mapped to the Flan
builtin that computes the same thing. Only exact equivalents: [mod] is left
out because Clojure's is floored and [%] is not. *)
let operator_aliases =
[ ("not=", ("!=", "Not-equal")); ("=/=", ("!=", "Not-equal"));
("/=", ("!=", "Not-equal")); ("<>", ("!=", "Not-equal"));
("==", ("=", "Equality")); ("===", ("=", "Equality"));
("&&", ("and", "Logical and")); ("||", ("or", "Logical or"));
("!", ("not", "Logical not")) ]
(* The fix, as the sentence that ends the refusal. The reader's call is
written back out under the Flan name only when every argument can be
spelled and the count is one the builtin takes, so a suggestion printed as
code compiles once pasted. An argument that cannot be spelled leaves the
call as it was, with only the name to change; a count the builtin does not
take gets the builtin's shape. *)
let alias_fix flan (args : Ast.expr list) =
let spelled = List.map (spell_arg "") args in
let n = List.length args in
let arity_ok =
match flan with
| "not" -> n = 1
| "and" | "or" -> true
| _ -> n >= 2
in
if not arity_ok then
Printf.sprintf "It is called as %s"
(if flan = "not" then "(not x)" else "(" ^ flan ^ " x y)")
else if List.mem "" spelled then Printf.sprintf "Write %s in its place" flan
else Printf.sprintf "Write (%s)" (String.concat " " (flan :: spelled))
(* What a [break] or a [continue] may be talking about, innermost first.
[Lloop] is a loop it is lexically inside, carrying its label if it was given
@ -1197,6 +1228,21 @@ let rec resolve env ?(seen = []) (t : Ast.texpr) : Types.t =
[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. *)
(* 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. *)
let constructors = [ "Ptr"; "Option"; "Vec"; "Map" ] in
(match
if Hashtbl.mem env.aliases name || Hashtbl.mem env.structs name
|| Hashtbl.mem env.datas name || Hashtbl.mem env.unions name
|| Hashtbl.mem env.enums name
then None
else near_miss env ~also:constructors name
with
| Some m when List.mem m constructors ->
Loc.failk "check/unknown-type" loc
"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"
@ -1396,6 +1442,53 @@ let is_type_name env n =
slot holding one is a type however few of them there are. *)
|| (n <> "" && n.[0] = '$')
(* A defn written without its return type puts the body's first form in the
slot, and [(dotimes [i n] ...)] parses as a type application. Every type
application's head is a constructor, and a constructor is capitalised, so a
lowercase head there — or the name of a function — is a body form and not a
malformed type. A capitalised head that is neither stays with [resolve],
whose unknown-type and no-type-arguments sentences are the right ones for
[(Vect i32)] and [(Pair i32)]. *)
let missing_return_type env (fn : Ast.fn) =
match fn.Ast.ret with
| Some { Ast.t = Ast.Tapp (head, args); tloc } ->
let lowercase =
head <> "" && not (head.[0] >= 'A' && head.[0] <= 'Z')
in
let constructor =
List.mem head [ "Ptr"; "Option"; "Vec"; "Map"; "Result" ]
in
(* [(vec i32)] is the constructor with the wrong case, not a body form —
but only while every argument is a type, since [(map inc xs)] is a
body form whose head is a function. *)
let args_are_types =
List.for_all
(fun (a : Ast.texpr) ->
match a.Ast.t with Ast.Tname n -> is_type_name env n | _ -> true)
args
in
(match
List.find_opt
(fun c -> String.lowercase_ascii c = String.lowercase_ascii head
&& c <> head)
[ "Ptr"; "Option"; "Vec"; "Map" ]
with
| Some c when args_are_types && not (is_type_name env head) ->
Loc.failk "check/unknown-type" tloc
"unknown type %s — did you mean %s?" head c
| _ -> ());
if (not constructor) && (not (is_type_name env head))
&& (lowercase || Hashtbl.mem env.fns head
|| List.mem head !builtin_names)
then
Loc.failk "check/return-type-missing" tloc
"%s has no return type: (%s ...) stands where the return type goes, \
and %s is not a type. The return type is written between the \
parameter vector and the body, and a function that returns nothing \
writes () there"
fn.Ast.name head head
| _ -> ()
(* Before a bare symbol is allowed to become an unannotated parameter, the two
ways it is more likely to be a type that went wrong.
@ -9355,6 +9448,15 @@ 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 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
these: [not=] is one edit from [not], which is the wrong answer,
and [&&] is no edit at all from [and]. *)
let flan, what = List.assoc name operator_aliases in
Loc.failk "check/unknown-function" loc
"there is no %s. %s is %s. %s" name what flan
(alias_fix flan args)
else if String.contains name '/' then
unimplemented loc
(Printf.sprintf "the call %s into an imported package" name) 4
@ -10980,6 +11082,7 @@ let collect env (decls : Ast.decl list) =
let fields = List.map field ms in
Hashtbl.replace env.unions n { Tast.sname = n; fields }
| Ast.Defn fn ->
missing_return_type env fn;
(* A signature that introduces a type variable is a *pattern*, not a
signature: it goes in [gsigs] and the function goes nowhere near
[fns], because nothing can be called at [t]. Every call site turns

View File

@ -649,6 +649,59 @@ let host_loc t name =
| Some f -> Loc.to_string f.Tast.floc
| None -> ""
(* A generic is never a [Tast.fn]: the checker keeps it as the AST it was
written as, and each type it is called at makes an ordinary copy under a
name of its own ([selection-sort-i32]). So a by-name op asked for the 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. *)
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
(Printf.sprintf "%s [%s] %s" name
(String.concat " " (List.map show params)) (show ret))
(* The copies of generic [name] the program holds, each with the types its
variables were bound to, spelled [$t = i32]. Read off the program: a copy
a [C-x C-e] made is kept in it, and [eval_expr] records the thunk's module
as that copy's owner, since no other module defines it. *)
let generic_copies t name =
let env = t.session.Session.env in
match Hashtbl.find_opt env.Check.gsigs name with
| None -> []
| Some (vars, params, ret) ->
List.filter_map
(fun (f : Tast.fn) ->
if f.Tast.fparent <> None then None
else
match Check.instantiation_origin env f.Tast.name with
| Some (g, ps) when String.equal g name ->
let subst = ref [] in
if List.length ps = List.length params then
ignore
(List.for_all2 (Check.bind_ty ~widen:true subst) params ps
&& Check.bind_ty subst ret f.Tast.ret);
let bound =
List.map
(fun v ->
match List.assoc_opt v !subst with
| Some ty -> Printf.sprintf "$%s = %s" v (Types.to_string ty)
| None -> "$" ^ v)
vars
in
Some (f, String.concat ", " bound)
| _ -> None)
t.session.Session.program.Tast.fns
(* By the types, alphabetically — [f64] before [i32] — so a listing asked
for twice is in the same order whatever order the copies were made in. *)
|> List.sort (fun (_, a) (_, b) -> String.compare a b)
(* ── Ops ───────────────────────────────────────────────────────────── *)
(* Every reply is a plist with a :status, so an editor can dispatch on one key
@ -1046,6 +1099,9 @@ let eval_expr t ~code ~origin ~pause =
the same instantiation would list it as already there. *)
let held = Session.held t.session in
let refused msg = Session.restore t.session held; error msg in
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
| c ->
let before = match result t with Some (g, _) -> g | None -> 0L in
@ -1077,10 +1133,32 @@ let eval_expr t ~code ~origin ~pause =
let entered_gen = stop_gen t 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
thunk's module and in no other, so this module is where [disassemble]
has to look for it — and its IR is kept for the reason [eval] keeps
a module's. *)
let ll =
Filename.concat t.dir (Printf.sprintf "e%d%s" t.n (module_ext c))
in
write_file ll c.Session.ir;
let copies =
List.filter_map
(fun (f : Tast.fn) ->
if List.mem f.Tast.name had then None else Some f.Tast.name)
t.session.Session.program.Tast.fns
in
(match build_module c ~debug:t.session.Session.debug ~out with
| _ ->
(match deliver t out with
| "ok" ->
if copies <> [] then begin
t.gen <- t.gen + 1;
List.iter
(fun n ->
Hashtbl.replace t.owners n
{ ogen = t.gen; oso = out; oll = ll; oloc = fn_loc t n })
copies
end;
(* Strictly after the delivery, and that ordering is the whole of
it: the sleeper is woken to look at a ring, so waking it before
the module is in one buys an empty poll and a five-second wait.
@ -1644,10 +1722,27 @@ let defs t =
(fun (name, sign, doc) -> entry ~name ~kind:"builtin" ~sign ~loc:"" ~doc ())
Check.builtins
in
(* A generic by the name it was written under. The program holds only its
copies, so without these rows the name an author typed was the one name
completion, eldoc and [M-.] had never heard of. Kind [fn], because it is
one to every reader of this list: it is called, jumped to, and
disassembled — the last through [disassemble], which answers a generic's
name with its copies. *)
let generics =
Hashtbl.fold
(fun name (g : Ast.fn) acc ->
entry ~name ~kind:"fn"
~sign:(Option.value ~default:name (generic_signature t name))
~loc:(Loc.to_string g.Ast.nloc) ()
:: acc)
t.session.Session.env.Check.generics []
|> List.sort compare
in
ok
[ ":defs "
^ Wire.list
(fns @ macros @ types @ globals @ externs @ prelude_macros @ builtins)
(fns @ generics @ macros @ types @ globals @ externs @ prelude_macros
@ builtins)
]
(* [(:op "layout" :type T)] — a struct's fields and their types.
@ -3757,22 +3852,9 @@ let kind_of t name =
then Some "an extern"
else None
let disassemble t ~name ~form =
if form <> "ir" && form <> "asm" then
error
(Printf.sprintf
"unknown form %S: disassemble takes :form \"ir\" or :form \"asm\"" form)
else
match find_fn t name with
| None ->
(match kind_of t name with
| Some k ->
error
(Printf.sprintf
"%s is %s, not a function: there is no generated code to show for it"
name k)
| None -> error (Printf.sprintf "no function named %s in this session" name))
| Some f ->
(* The fields of one function's listing, or why there is none. [name] is the
symbol the code was built under, which for a generic's copy is the copy's. *)
let disassemble_fn t ~name ~form (f : Tast.fn) =
let o, why = basis t name in
let common =
[ ":name " ^ Wire.quote name; ":form " ^ Wire.quote form;
@ -3793,7 +3875,7 @@ let disassemble t ~name ~form =
it cannot answer rather than failing at the text of an answer it was
never going to find. *)
if form = "ir" && t.session.Session.x86 then
error
Error
"this session was compiled by the x86 dev backend, so there is no \
LLVM IR to show — the listing it produced is assembly. C-c C-a \
disassembles the object, which works here; for the IR view, restart \
@ -3803,13 +3885,13 @@ let disassemble t ~name ~form =
| text ->
(match ir_of ~ir:text name with
| Some body ->
ok (common @ [ ":object " ^ Wire.quote o.oll; ":text " ^ Wire.quote body ])
Ok (common @ [ ":object " ^ Wire.quote o.oll; ":text " ^ Wire.quote body ])
| None ->
error (Printf.sprintf "no define for %s in %s" (Emit.fname name) o.oll))
Error (Printf.sprintf "no define for %s in %s" (Emit.fname name) o.oll))
| exception Sys_error m ->
error ("the IR this body was built from is gone: " ^ m)
Error ("the IR this body was built from is gone: " ^ m)
else if not (Sys.file_exists o.oso) then
error ("the object this body was linked into is gone: " ^ o.oso)
Error ("the object this body was linked into is gone: " ^ o.oso)
else
(* The kept source is what the source lines come from: the assembly's
map on x86, the [.ll]'s headings for an LLVM line table. Missing is
@ -3837,12 +3919,75 @@ let disassemble t ~name ~form =
"source interleaving needs line tables, which an LLVM \
session has only when started with flan dev --llvm --debug" ]
in
ok
Ok
(common
@ [ ":object " ^ Wire.quote o.oso ]
@ note
@ [ ":text " ^ Wire.quote text ])
| Error m -> error m
| Error m -> Error m
(* A generic's name answers with its copies: one is shown as any function is,
with [:generic] and [:types] beside it, and several come back as
[:copies], a list of those replies, one per type it was called at. *)
let disassemble t ~name ~form =
if form <> "ir" && form <> "asm" then
error
(Printf.sprintf
"unknown form %S: disassemble takes :form \"ir\" or :form \"asm\"" form)
else
match find_fn t name with
| Some f ->
(match disassemble_fn t ~name ~form f with
| Ok fields -> ok fields
| Error m -> error m)
| None when Check.is_generic t.session.Session.env name ->
let sign = Option.value ~default:name (generic_signature t name) in
let copy ((f : Tast.fn), bound) =
Result.map
(fun fields ->
fields
@ [ ":generic " ^ Wire.quote name; ":types " ^ Wire.quote bound ])
(disassemble_fn t ~name:f.Tast.name ~form f)
in
(match generic_copies t name with
| [] ->
error
(Printf.sprintf
"%s is generic — %s — and nothing in this session calls it \
yet, so no code has been made for it. Each type it is called \
at gets its own compiled copy: evaluate a function that calls \
it, then disassemble %s again"
name sign name)
| [ c ] ->
(match copy c with Ok fields -> ok fields | Error m -> error m)
| cs ->
(* One copy that cannot be shown is that copy's entry, named with
the reason, and not the whole reply: the others still have code
to read. *)
let entry (((f : Tast.fn), bound) as c) =
match copy c with
| Ok fields -> Wire.list fields
| Error m ->
Wire.list
[ ":name " ^ Wire.quote f.Tast.name;
":signature " ^ Wire.quote (signature_of_fn f);
":loc " ^ Wire.quote (fn_loc t f.Tast.name);
":generic " ^ Wire.quote name; ":types " ^ Wire.quote bound;
":refused " ^ Wire.quote m ]
in
ok
[ ":name " ^ Wire.quote name; ":form " ^ Wire.quote form;
":generic " ^ Wire.quote name;
":signature " ^ Wire.quote sign;
":copies " ^ Wire.list (List.map entry cs) ])
| None ->
(match kind_of t name with
| Some k ->
error
(Printf.sprintf
"%s is %s, not a function: there is no generated code to show for it"
name k)
| None -> error (Printf.sprintf "no function named %s in this session" name))
(* ── The watch table ───────────────────────────────────────────────── *)

View File

@ -3290,6 +3290,161 @@ let () =
(* ── Disassembly ───────────────────────────────────────────────── *)
(* A generic is compiled only as its copies, one per type it is called at,
so its own name has to be answered with those — the name the author
typed is the one the program never holds. Sent from a file that is not
the program's, which is how the report came in. Run against a daemon
of each backend, with the view each one has. *)
let generic_disassembly c ~backend ~form =
let said r = Option.value ~default:"" (Wire.string_field r "message") in
let file = "/tmp/flan-devtest-sorts.flan" in
let eval code =
request c
(Printf.sprintf "(:op \"eval\" :code %s :file %s)" (Wire.quote code)
(Wire.quote file))
in
let ask () =
request c
(Printf.sprintf
"(:op \"disassemble\" :name \"selection-sort\" :form %S)" form)
in
let r =
eval
"(defn selection-sort [xs [$t]] ()\n {:where (ordered? $t)}\n \
(dotimes [i (length xs)]\n (let [m i]\n (dotimes [j \
(length xs)]\n (when (< (at xs j) (at xs m)) (set m j)))\n \
(swap xs i m))))"
in
if status r <> "ok" then fail "%s: sending a generic: %s" backend (said r)
else begin
let r = ask () in
if status r <> "error" then
fail "%s: a generic nothing calls was disassembled" backend
else if not (contains_sub (said r) "is generic")
|| not (contains_sub (said r) "[[$t]]")
|| not (contains_sub (said r) "evaluate a function that calls it")
then fail "%s: a generic nothing calls is refused for the wrong reason: %s"
backend (said r);
let r = request c "(:op \"defs\")" in
(match Wire.field r "defs" with
| Some { Form.v = Form.List rows; _ } ->
let row =
List.find_opt
(fun (d : Form.t) ->
match d.Form.v with
| Form.List ({ Form.v = Form.Str "selection-sort"; _ } :: _) ->
true
| _ -> false)
rows
in
(match row with
| Some { Form.v = Form.List [ _; { Form.v = Form.Str "fn"; _ };
{ Form.v = Form.Str sign; _ };
{ Form.v = Form.Str loc; _ }; _ ]; _ }
->
if sign <> "selection-sort [[$t]] ()" then
fail "%s: the generic's signature is not as written: %s" backend sign;
if loc <> file ^ ":1:7" then
fail "%s: the generic's location is not where it was sent from: %s"
backend loc
| _ -> fail "%s: defs does not list the generic by its name" backend)
| _ -> fail "%s: defs answered no list" backend);
let r =
eval
"(defn use-sort [] ()\n (let [a [3 1 2]] (selection-sort (slice a 0 3))))"
in
if status r <> "ok" then fail "%s: calling the generic at i32: %s" backend (said r)
else begin
let r = ask () in
if status r <> "ok" then
fail "%s: the generic with one copy: %s" backend (said r)
else begin
if Wire.string_field r "name" <> Some "selection-sort-i32" then
fail "%s: the one copy is not the one shown" backend;
if Wire.string_field r "types" <> Some "$t = i32" then
fail "%s: the one copy does not say its types" backend;
if Wire.string_field r "loc" <> Some (file ^ ":1:7") then
fail "%s: the one copy does not name the file it came from: %s"
backend (Option.value ~default:"" (Wire.string_field r "loc"));
if not (contains_sub
(Option.value ~default:"" (Wire.string_field r "text"))
(if form = "ir" then "flan.selection-sort-i32" else "ret"))
then fail "%s: the one copy's listing is not its code" backend
end
end;
let r =
eval
"(defn use-sort [] ()\n (let [a [3 1 2]] (selection-sort (slice a 0 3)))\n \
(let [b [3.0 1.0]] (selection-sort (slice b 0 2))))"
in
if status r <> "ok" then fail "%s: calling the generic at f64: %s" backend (said r)
else begin
let r = ask () in
if status r <> "ok" then
fail "%s: the generic with two copies: %s" backend (said r)
else
match Wire.field r "copies" with
| Some { Form.v = Form.List [ a; b ]; _ } ->
let types f =
Option.value ~default:"" (Wire.string_field f "types")
in
if types a <> "$t = f64" || types b <> "$t = i32" then
fail "%s: the copies are not headed by their types: %s, %s"
backend (types a) (types b);
List.iter
(fun f ->
let name = Option.value ~default:"" (Wire.string_field f "name") in
let text = Option.value ~default:"" (Wire.string_field f "text") in
if form = "ir" && not (contains_sub text ("flan." ^ name)) then
fail "%s: the copy %s shows some other code" backend name;
if text = "" then fail "%s: the copy %s has no listing" backend name)
[ a; b ]
| _ -> fail "%s: two copies did not come back as two" backend
end;
(* A copy made by an evaluated expression is defined only in that
expression's module, which is where its code has to be read from —
and the copies made before it are still shown beside it. *)
let r =
request c
"(:op \"eval-expr\" :code \"(selection-sort (slice [(i64 3) (i64 1)] 0 2))\")"
in
if status r <> "ok" then
fail "%s: calling the generic at i64 from an expression: %s" backend (said r)
else begin
let r = ask () in
if status r <> "ok" then
fail "%s: the generic with a copy an expression made: %s" backend (said r)
else
match Wire.field r "copies" with
| Some { Form.v = Form.List [ _; _; _ ] as l; _ } ->
let l = match l with Form.List l -> l | _ -> [] in
List.iter
(fun f ->
let name = Option.value ~default:"" (Wire.string_field f "name") in
match Wire.string_field f "refused" with
| Some m -> fail "%s: the copy %s has no listing: %s" backend name m
| None ->
let text = Option.value ~default:"" (Wire.string_field f "text") in
if form = "ir" && not (contains_sub text ("flan." ^ name)) then
fail "%s: the copy %s shows some other code" backend name;
if text = "" then fail "%s: the copy %s has no listing" backend name)
l;
(match
List.find_opt
(fun f -> Wire.string_field f "types" = Some "$t = i64") l
with
| Some f ->
(match Wire.string_field f "object" with
| Some o when String.starts_with ~prefix:"e" (Filename.basename o) -> ()
| o ->
fail "%s: the expression's copy is not read from its module: %s"
backend (Option.value ~default:"" o))
| None -> fail "%s: the expression's copy is not listed" backend)
| _ -> fail "%s: three copies did not come back as three" backend
end
end
in
(* A third daemon, over a program that keeps running, because the two
claims here are about *which* module owns a name and what the answer is
allowed to say it means — and both change the moment a body is
@ -3457,6 +3612,7 @@ let () =
"\"ir\" or";
refused "a request with no name" "(:op \"disassemble\" :form \"asm\")"
"needs :name";
generic_disassembly c ~backend:"llvm" ~form:"ir";
(* A stopped program has not thereby failed to install. The commonest way
to stop is to install a body and have it error, so the one thing the
@ -3738,6 +3894,7 @@ let () =
fail "annotate: the delivered wind's positions are not the buffer's:\n%s"
(text r)
end;
generic_disassembly c ~backend:"x86" ~form:"asm";
ignore (request c "(:op \"close\")");
Unix.close c;
if not

View File

@ -2446,6 +2446,69 @@ let () =
reach past anything. Four claims: the call is refused, the refusal says
what to write instead, the name binds in every position, and a defn under
it earns no shadowing warning. *)
(* ── Operators spelled as other languages spell them ─────────────── *)
rejects_check "not= names !="
"(defn f [a i32 b i32] bool (not= a b))"
~needle:"there is no not=. Not-equal is !=. Write (!= a b)";
accepts "and the call it writes compiles"
"(defn f [a i32 b i32] bool (!= a b))";
rejects_check "not= over calls says which name to change"
"(defn f [a i32 b i32] bool (not= (+ a 1) b))"
~needle:"Write != in its place";
rejects_check "/= is not a package call"
"(defn f [a i32 b i32] bool (/= a b))" ~needle:"Write (!= a b)";
rejects_check "=/= is not a package call"
"(defn f [a i32 b i32] bool (=/= a b))" ~needle:"Write (!= a b)";
rejects_check "== names ="
"(defn f [a i32 b i32] bool (== a b))" ~needle:"Write (= a b)";
rejects_check "&& names and"
"(defn f [a bool b bool] bool (&& a b))" ~needle:"Write (and a b)";
accepts "and that call compiles" "(defn f [a bool b bool] bool (and a b))";
rejects_check "|| names or"
"(defn f [a bool b bool] bool (|| a b))" ~needle:"Write (or a b)";
rejects_check "! names not"
"(defn f [a bool] bool (! a))" ~needle:"Write (not a)";
rejects_check "a ! at an arity not does not take gets not's shape"
"(defn f [a bool b bool] bool (! a b))" ~needle:"called as (not x)";
rejects_check "a bare && is written back as the and that compiles"
"(defn f [] bool (&&))" ~needle:"Write (and)";
accepts "and it does" "(defn f [] bool (and))";
accepts "a program's own not= is its own"
"(defn not= [a i32 b i32] bool (!= a b)) \
(defn f [a i32 b i32] bool (not= a b))";
(* ── A defn with no return type ───────────────────────────────────
The body's first form lands in the return slot and parses as a type
application; the refusal names the missing return type rather than the
form's head. *)
rejects_check "a body form in the return slot is a missing return type"
"(defn f [s string] (dotimes [i (length s)] (println i)))"
~needle:"f has no return type: (dotimes ...) stands where the return type goes";
rejects_check "and says how a function returning nothing is written"
"(defn f [a i32 b i32] (+ a b))"
~needle:"a function that returns nothing writes () there";
accepts "the fix compiles"
"(defn f [s string] () (dotimes [i (length s)] (println i)))";
accepts "a type application in the slot is still a type"
"(defn f [] (Option i32) None)";
rejects_check "a misspelled constructor is a near miss"
"(defn f [] (Optoin i32) None)" ~needle:"unknown type Optoin — did you mean Option?";
rejects_check "a lowercase vec is Vec"
"(defn f [] (vec i32) (vec-new i32))" ~needle:"unknown type vec — did you mean Vec?";
rejects_check "a lowercase ptr is Ptr"
"(defn f [p (Ptr i32)] (ptr i32) p)" ~needle:"unknown type ptr — did you mean Ptr?";
rejects_check "a lowercase option is Option"
"(defn f [] (option i32) None)" ~needle:"unknown type option — did you mean Option?";
rejects_check "a lowercase map is Map"
"(defn f [] (map i32 i32) (map-new i32 i32))"
~needle:"unknown type map — did you mean Map?";
rejects_check "a map over values in the slot is a body form"
"(defn f [inc i32 xs i32] (map inc xs))" ~needle:"f has no return type";
rejects_check "an unknown capitalised head keeps the generics sentence"
"(defn f [] (Pair i32) 0)" ~needle:"Pair takes no type arguments";
rejects_check "a misspelled plain return type is still an unknown type"
"(defn f [] i3 0)" ~needle:"unknown type i3";
rejects_check "len is not a builtin"
"(defn f [s [i32]] i32 (len s))" ~needle:"there is no len";
rejects_check "and the refusal writes the call out"