A generic's name disassembles to each of its copies, and completion knows the name
This commit is contained in:
commit
5e9be2150f
9
TODO.org
9
TODO.org
@ -1080,6 +1080,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";
|
||||
@ -1931,6 +1935,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
|
||||
|
||||
@ -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))))
|
||||
|
||||
@ -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.
|
||||
|
||||
@ -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)
|
||||
|
||||
193
lib/dev.ml
193
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 ───────────────────────────────────────────────── *)
|
||||
|
||||
|
||||
157
test/test_dev.ml
157
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
|
||||
|
||||
Loading…
x
Reference in New Issue
Block a user