diff --git a/emacs/flan-lower.el b/emacs/flan-lower.el index 1da34463..4ca995a5 100644 --- a/emacs/flan-lower.el +++ b/emacs/flan-lower.el @@ -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)))) diff --git a/emacs/flan.el b/emacs/flan.el index b1ec4960..51637be3 100644 --- a/emacs/flan.el +++ b/emacs/flan.el @@ -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. diff --git a/emacs/test-flan.el b/emacs/test-flan.el index 30bb649e..a7336357 100644 --- a/emacs/test-flan.el +++ b/emacs/test-flan.el @@ -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]] ()" ":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/dev.ml b/lib/dev.ml index aa138b5a..68f61af1 100644 --- a/lib/dev.ml +++ b/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 ───────────────────────────────────────────────── *) diff --git a/test/test_dev.ml b/test/test_dev.ml index 3d8ff53c..dbba89ea 100644 --- a/test/test_dev.ml +++ b/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