diff --git a/TODO.org b/TODO.org index d8558474..4082966a 100644 --- a/TODO.org +++ b/TODO.org @@ -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 diff --git a/emacs/flan-lower.el b/emacs/flan-lower.el index 1fe0f6c9..4fdd3268 100644 --- a/emacs/flan-lower.el +++ b/emacs/flan-lower.el @@ -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)))) diff --git a/emacs/flan.el b/emacs/flan.el index 0f60efd1..2b9b8aad 100644 --- a/emacs/flan.el +++ b/emacs/flan.el @@ -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. diff --git a/emacs/test-flan.el b/emacs/test-flan.el index 762551ed..c0938cd2 100644 --- a/emacs/test-flan.el +++ b/emacs/test-flan.el @@ -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]] ()" ":331:7" "") + ("sort-i32" "fn" "sort-i32 [[i32]] ()" ":331:7" "") + ("sort-f64" "fn" "sort-f64 [[f64]] ()" ":331:7" "") + ("sort-bytes" "fn" "sort-bytes [[[u8]]] ()" ":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) diff --git a/lib/check.ml b/lib/check.ml index ff93f8bb..80b92b58 100644 --- a/lib/check.ml +++ b/lib/check.ml @@ -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 diff --git a/lib/dev.ml b/lib/dev.ml index dd6c6fbe..dfe19dda 100644 --- a/lib/dev.ml +++ b/lib/dev.ml @@ -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 ───────────────────────────────────────────────── *) diff --git a/test/test_dev.ml b/test/test_dev.ml index 77547f29..14f11ef1 100644 --- a/test/test_dev.ml +++ b/test/test_dev.ml @@ -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 diff --git a/test/test_flan.ml b/test/test_flan.ml index 323cf3ee..2e265ce7 100644 --- a/test/test_flan.ml +++ b/test/test_flan.ml @@ -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"