A generic's name disassembles to its copies, each headed by the types it was called at, and is listed among the program's names
This commit is contained in:
parent
b818e38cff
commit
b05a97b029
@ -415,6 +415,38 @@ 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."
|
||||
(let ((parts
|
||||
(delq nil
|
||||
(mapcar
|
||||
(lambda (c)
|
||||
(let ((text (funcall flan-lower-fetch-function
|
||||
section flan-lower--file c
|
||||
flan-lower--flags)))
|
||||
(and text (format ";; %s\n%s" c text))))
|
||||
(flan-lower--copies name)))))
|
||||
(and parts (mapconcat #'identity parts "\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 +457,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))))
|
||||
|
||||
@ -2948,36 +2948,68 @@ 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)))
|
||||
(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.
|
||||
|
||||
@ -1798,6 +1798,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)))
|
||||
|
||||
@ -1817,6 +1855,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)
|
||||
|
||||
162
lib/dev.ml
162
lib/dev.ml
@ -637,6 +637,57 @@ 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 and not
|
||||
off the instantiation table: a copy a [C-x C-e] thunk asked for is in the
|
||||
table and in no program, and there is no build of it to show. *)
|
||||
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
|
||||
|> 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
|
||||
@ -1632,10 +1683,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.
|
||||
@ -3745,22 +3813,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;
|
||||
@ -3781,7 +3836,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 \
|
||||
@ -3791,13 +3846,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
|
||||
@ -3825,12 +3880,71 @@ 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 ->
|
||||
let rec all acc = function
|
||||
| [] -> Ok (List.rev acc)
|
||||
| c :: rest ->
|
||||
(match copy c with
|
||||
| Ok fields -> all (Wire.list fields :: acc) rest
|
||||
| Error m -> Error m)
|
||||
in
|
||||
(match all [] cs with
|
||||
| Error m -> error m
|
||||
| Ok copies ->
|
||||
ok
|
||||
[ ":name " ^ Wire.quote name; ":form " ^ Wire.quote form;
|
||||
":generic " ^ Wire.quote name;
|
||||
":signature " ^ Wire.quote sign;
|
||||
":copies " ^ Wire.list copies ]))
|
||||
| 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 ───────────────────────────────────────────────── *)
|
||||
|
||||
|
||||
116
test/test_dev.ml
116
test/test_dev.ml
@ -3290,6 +3290,120 @@ 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
|
||||
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 +3571,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 +3853,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