diff --git a/NEXT.md b/NEXT.md index dc81c86..0557113 100644 --- a/NEXT.md +++ b/NEXT.md @@ -822,6 +822,7 @@ request and `read` reads a reply. | `C-c C-r` | a prompt on the running program (`*flan-repl*`) | | `C-c C-b` | what a **stopped** program is offering, and which to take | | `C-c C-d` | what the running program currently defines | +| `C-c C-a` | the code a name compiled to — amd64, or `C-u` for the LLVM IR | | `M-.` / `M-,` | where a name is written, through an `xref` backend | eldoc, `completion-at-point` and `M-.` all read one cached `defs` reply rather than asking per keystroke: eldoc fires on @@ -856,15 +857,42 @@ An accepted evaluation says which names landed and what the build cost, and flas success is indistinguishable from silent failure, and `beginning-of-defun` may well have found a different form from the one point looked like it was in. -**TODO — live disassembly.** Add an editor command that asks the live Flan session for a named function's generated code -and shows a disassembly (with the source location and reload generation it came from). `flan emit --dev` can show LLVM -IR for a whole source file today, but neither the daemon nor Emacs can inspect the native code currently installed in an -indirection cell. There should be options to both show the LLVM IR but also the target platform assembly, which in my -case is amd64, if that's possible. Take a look at how SBCL does it for reference. +**Live disassembly — done.** `C-c C-a` on a name writes the amd64 the running program's copy of it was assembled to +into `*flan-disassembly*`; `C-u C-c C-a` writes the LLVM IR that body was built from. `(:op "disassemble" :name … :form +"asm"|"ir")` is the op. -**TODO — transient error overlays.** The diagnostic ghost text should vanish as soon as the user does anything else in -that buffer — edit, move, evaluate, or invoke another command — rather than surviving until a later evaluation is -accepted. It is feedback about the action that just failed, not a durable annotation on the source. +What makes it possible is that the daemon owns the build: it compiled every module it sent, so `objdump -d +--disassemble=flan.` on the right object *is* the disassembly and the retained `.ll` is the IR. `Build.shared` +deletes its own `.ll` and `Build.executable` leaves the host's under a name that says nothing about which module it was, +so the daemon now writes its own copy beside each `.so` and keeps the host's as `host.ll` — ten reloads in, nothing else +on the machine still has that text. A table from function name to the last module accepted for it is the whole of the +bookkeeping. + +**What it will not claim is that the code shown is installed**, and this is the interesting half. The agent's socket +takes a module path and five verbs; none of them reports an address, `flan_dev_cell` lives in the program's address +space, and `C-x C-e` renders a pointer as `` on purpose — so nothing the daemon can ask would tell it what a cell +holds. The reply carries `:basis` saying which of three things is true, and the buffer prints it above the first +instruction: + +- nothing has been delivered for this name, so the cell still holds the host's body — the one case that is *certain*; +- a module was delivered and the agent queued it, and the program installs it at its next frame boundary — unconfirmed; +- a module was delivered and the program is **stopped** — which says nothing either way about whether it installed, +since the commonest way to stop is to install a body and have it error; what is certain is only that nothing further +installs until it resumes. + +From SBCL: offsets from the function's own start rather than addresses into an object, and `L0:` labels on branch +targets with the file address that duplicates them dropped. Not source interleaving — SBCL has the mapping and this +build emits no line tables — so the reply says that in words rather than printing a listing with no source in it. When +the debug build lands, that is the line to delete. + +**Transient error overlays — done.** The diagnostic ghost text is feedback about the evaluation that just failed, not an +annotation on the source, so the next command in that buffer takes it down — edit, motion, evaluation, anything. +`pre-command-hook` and not `post-command-hook`, which fires at the end of the *failing* command and would clear the +overlay before redisplay had drawn it. The hook is buffer-local and lives exactly as long as an overlay does: added +where one is drawn, removed where they are cleared, so a session of twenty buffers is not running it on every keystroke +in all of them. `execute-kbd-macro` runs no `pre-command-hook` under `--batch`, so the test drives `run-hooks` — the +same call the command loop makes — and checks the hook is installed in that buffer and in no other; that Emacs runs it +is Emacs' contract and a test claiming to check it would be checking nothing. **The program's stdout is a pipe into the daemon**, and whatever it printed since the last reply rides along with the next one into `*flan-output*`. Having it arrive *with* a reply rather than by a separate request is the point: the diff --git a/emacs/flan-dev.el b/emacs/flan-dev.el index 333bac2..fc612b6 100644 --- a/emacs/flan-dev.el +++ b/emacs/flan-dev.el @@ -731,9 +731,27 @@ Compared with `file-equal-p', so a symlinked or relative path still matches." ;; An error is shown where it is rather than only in the echo area, because the ;; echo area is gone the moment you type and the location is the useful half of -;; the message. It is cleared when the next evaluation of that buffer is -;; accepted: an overlay left behind after a fix is a lie about the program, and -;; a stale one is worse than none. +;; the message. +;; +;; It is feedback about the evaluation that just failed and not an annotation +;; on the source, so it lasts exactly as long as that: the next command in that +;; buffer takes it away, whatever the command was — a keystroke, a motion, +;; another evaluation. An overlay that survived until some later evaluation +;; was accepted outlived the thing it was about, and a stale one is worse than +;; none. +;; +;; `pre-command-hook' and not `post-command-hook': the hook has to run before +;; the *next* command, because `post-command-hook' fires at the end of the +;; failing command itself and would take the overlay down before redisplay had +;; ever drawn it. +;; +;; The hook is buffer-local and lives exactly as long as an overlay does — +;; added where one is drawn, removed where they are cleared. Globally it would +;; be a hook every buffer in the session runs on every keystroke for the sake +;; of a feature most of them will never use; buffer-locally it is also the +;; behaviour asked for, since the overlay belongs to the buffer the failed +;; evaluation came from and a command somewhere else is not "doing something +;; else in that buffer". (defface flan-dev-error-face '((t :inherit error :underline (:style wave))) @@ -745,11 +763,29 @@ Compared with `file-equal-p', so a symlinked or relative path still matches." "Face for the message shown beside a rejected form." :group 'flan-dev) +(defun flan-dev--error-overlays (&optional buffer) + "The Flan error overlays in BUFFER, or in the current buffer." + (with-current-buffer (or buffer (current-buffer)) + (seq-filter (lambda (o) (overlay-get o 'flan-dev-error)) + (overlays-in (point-min) (point-max))))) + (defun flan-dev-clear-errors (&optional buffer) "Remove Flan error overlays from BUFFER, or from the current buffer." (interactive) (with-current-buffer (or buffer (current-buffer)) - (remove-overlays (point-min) (point-max) 'flan-dev-error t))) + (remove-overlays (point-min) (point-max) 'flan-dev-error t) + ;; With nothing left to clear there is nothing for the hook to do, and a + ;; hook that stays installed after the last overlay is gone is the half of + ;; this that quietly accumulates. + (remove-hook 'pre-command-hook #'flan-dev--clear-errors-on-command t))) + +(defun flan-dev--clear-errors-on-command () + "Take this buffer's error overlays down, as a `pre-command-hook'. +Any command at all, because the overlay is about the evaluation that failed +and not about the text: moving, typing and evaluating are all something +else, and an overlay that survived a fix would be pointing at code that is +no longer wrong." + (flan-dev-clear-errors)) (defun flan-dev--show-error (loc msg) "Mark MSG at LOC, if LOC names a file some buffer is visiting. @@ -771,6 +807,10 @@ Returns non-nil when it put an overlay somewhere." (overlay-put ov 'after-string (propertize (concat " " msg) 'face 'flan-dev-error-message-face)) + ;; Local to this buffer, and installed only now that there is + ;; something for it to remove. + (add-hook 'pre-command-hook + #'flan-dev--clear-errors-on-command nil t) ;; Point goes there too, but only in the buffer being looked at: ;; moving point in a buffer nobody is showing is a surprise the ;; next time it is visited. @@ -1079,6 +1119,10 @@ of the tenth name tells you neither how many there were nor which." (note (plist-get reply :note)) (value (plist-get reply :value))) ;; Accepted, so whatever the last rejection marked is no longer true. + ;; Redundant now that any command clears it — the command that ran this + ;; evaluation already did — and kept because it is the claim being + ;; made, not the mechanism: an accepted evaluation is never left with a + ;; rejection drawn over it. (flan-dev-clear-errors) ;; ...and a name that was just installed should complete, and have a ;; signature, from this moment rather than from the next connect. @@ -1186,5 +1230,121 @@ arrive in the same load or the first refers to storage that does not exist." (interactive "r") (flan-dev--eval (flan-dev--text start end) "region" start end)) +;;; Disassembly + +;; `flan emit --dev' prints the IR a source file would compile to. This asks a +;; different question: what did the code the running program is calling for +;; this name actually come out as. Only the daemon can answer it, because the +;; daemon compiled every module it sent and still has both the .ll and the .so +;; — so the editor asks rather than shelling out to a compiler of its own, +;; which would show what the source says today and not what was installed. +;; +;; The header is SBCL's habit: say which function, from where, and out of +;; which object, before a line of code. The one line that matters most is +;; `showing', which is the daemon's own account of how much its answer claims +;; — there is no way to read an indirection cell back, so a body that has been +;; delivered is not thereby known to be installed, and the buffer says which of +;; the two it is looking at rather than letting the listing imply the stronger +;; one. + +(defvar flan-disassembly-buffer "*flan-disassembly*" + "Buffer `flan-disassemble' writes into.") + +(define-derived-mode flan-disassembly-mode special-mode "Flan-Disasm" + "Mode for the buffer `flan-disassemble' writes." + (setq-local truncate-lines t)) + +(defun flan-disassemble--header (label text) + "Insert a header line naming LABEL with TEXT, wrapped under the label." + (let ((fill-column 78) + (start (point))) + (insert (format "; %-11s %s\n" label text)) + (fill-region start (point)) + ;; `fill-region' breaks the line but does not carry the comment character + ;; onto the continuation, and a listing whose header stops being a comment + ;; halfway down reads as output rather than as commentary. + (save-excursion + (goto-char start) + (forward-line 1) + (while (< (point) (point-max)) + (insert "; ") + (forward-line 1))) + (put-text-property start (point) 'face 'font-lock-comment-face))) + +;;;###autoload +(defun flan-disassemble (name &optional ir) + "Show the code NAME last compiled to in the running program's own build. + +With a prefix argument, or non-nil IR, show the LLVM IR the body was built +from instead of the machine code it was assembled to. + +The name is resolved the way `M-.' resolves one: exactly first, then as the +tail of exactly one packaged name, because a buffer inside a package writes +`settle' for what the program calls `sim/settle'." + (interactive + (list (or (thing-at-point 'symbol t) + (completing-read + "Disassemble: " + (mapcar #'car (seq-filter (lambda (d) (equal (nth 1 d) "fn")) + flan-dev--defs)) + nil t nil nil + (and (fboundp 'flan-current-defun-name) + (flan-current-defun-name)))) + current-prefix-arg)) + (when (process-live-p flan-dev--connection) + (ignore-errors (flan-dev-refresh-defs))) + (let* ((d (flan-dev--lookup name)) + ;; Ambiguity is refused here rather than sent: the daemon would find + ;; no such name and say so, which is true and useless — it is this end + ;; that knows the buffer wrote a short name and that several program + ;; names end in it. + (_ (unless d + (when-let ((hits (flan-dev--ambiguous name))) + (user-error "flan: %s could be %s; write the one you mean" + name (string-join (mapcar #'car hits) " or "))))) + (full (if d (nth 0 d) name)) + (form (if ir "ir" "asm")) + (r (flan-dev--request (list :op "disassemble" :name full :form form)))) + (unless (equal (plist-get r :status) "ok") + (user-error "flan: %s" (or (plist-get r :message) "refused"))) + (with-current-buffer (get-buffer-create flan-disassembly-buffer) + (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") + (insert (plist-get r :text)) + (goto-char (point-min)))) + (display-buffer flan-disassembly-buffer))) + +;;;###autoload +(defun flan-disassemble-ir (name) + "Show the LLVM IR NAME's installed body was built from. +`flan-disassemble' with a prefix argument does the same thing; this exists so +that the IR half is findable by name rather than only by a modifier." + (interactive + (list (or (thing-at-point 'symbol t) + (completing-read + "LLVM IR for: " + (mapcar #'car (seq-filter (lambda (d) (equal (nth 1 d) "fn")) + flan-dev--defs)) + nil t)))) + (flan-disassemble name t)) + (provide 'flan-dev) ;;; flan-dev.el ends here diff --git a/emacs/flan-mode.el b/emacs/flan-mode.el index f515972..c99393b 100644 --- a/emacs/flan-mode.el +++ b/emacs/flan-mode.el @@ -128,6 +128,10 @@ line is off screen." ;; C-h after a prefix is how anyone finds out what is under C-c, and a ;; binding there takes that away. (define-key map (kbd "C-c C-v") #'flan-doc) + ;; The code the running program is calling for a name, as amd64 or as the + ;; IR it was built from. C-u for the IR rather than a second key: it is + ;; the same question asked of the same body. + (define-key map (kbd "C-c C-a") #'flan-disassemble) ;; The way out when a reload is refused: rebuild, relaunch, reconnect. (define-key map (kbd "C-c C-x") #'flan-dev-restart-program) map) diff --git a/emacs/test-flan-dev.el b/emacs/test-flan-dev.el index cd5cfa9..d21a932 100644 --- a/emacs/test-flan-dev.el +++ b/emacs/test-flan-dev.el @@ -628,6 +628,90 @@ is written instead — the real `message' call the real command makes." (test-flan--check "and says nothing above the first one" (null (flan-current-defun-name)))) + ;; ── A rejection lasts as long as the action it was about ────────────── + ;; + ;; The overlay is feedback on the evaluation that just failed, so the next + ;; command in that buffer takes it down. What is checked here is the + ;; mechanism and not Emacs' command loop: `execute-kbd-macro' under --batch + ;; runs no `pre-command-hook' at all (and does not even move point), so there + ;; is no way from here to make the real loop run one. `run-hooks' is what + ;; the loop calls, and calling it is the closest honest thing — it proves the + ;; hook is installed, in the right buffer and nowhere else, and that running + ;; it clears the overlay and uninstalls itself. It does not prove Emacs runs + ;; it, which is Emacs' own contract. + (let ((buf (flan-dev--buffer-visiting file))) + (with-current-buffer buf + (flan-dev-clear-errors) + (let ((marked (flan-dev--show-error (format "%s:2:1" file) "no such name"))) + (test-flan--check "a rejection is marked in the buffer it came from" + (and marked (flan-dev--error-overlays))) + (test-flan--check "and the buffer is armed to take it down again" + (memq #'flan-dev--clear-errors-on-command + pre-command-hook)) + ;; Buffer-local, or every buffer in the session runs this on every + ;; keystroke for the sake of a buffer that had one bad evaluation. + (test-flan--check "and nobody else is" + (not (memq #'flan-dev--clear-errors-on-command + (default-value 'pre-command-hook)))) + (run-hooks 'pre-command-hook) + (test-flan--check "the next command in that buffer clears it" + (null (flan-dev--error-overlays))) + (test-flan--check "and the hook goes with the last overlay" + (not (memq #'flan-dev--clear-errors-on-command + pre-command-hook)))))) + + ;; ── Disassembly ─────────────────────────────────────────────────────── + ;; + ;; Its own daemon, because the first one was disconnected above and a + ;; disassembly is a question only a live session can answer: the daemon is + ;; the thing that built the module and still has the .ll and the .so. + (let ((socket3 (concat socket "-disasm"))) + (ignore-errors (delete-file socket3)) + (flan-dev program socket3) + (test-flan--check "a daemon to disassemble against" + (process-live-p flan-dev--connection)) + + (when (executable-find "objdump") + (flan-disassemble "step") + (with-current-buffer flan-disassembly-buffer + (let ((text (buffer-string))) + (test-flan--check "C-c C-a writes a disassembly of the name" + (string-match-p "\\`; disassembly for step" text)) + ;; The header is the half a listing cannot carry: what the answer + ;; claims, which for generated code is never "this is running". + (test-flan--check "with the daemon's own account of what it shows" + (string-match-p "showing" text)) + (test-flan--check "and instructions under it, numbered from zero" + (string-match-p "^ 0000 " text))))) + + ;; The other half of the same question, on the same body. + (flan-disassemble "step" t) + (with-current-buffer flan-disassembly-buffer + (let ((text (buffer-string))) + (test-flan--check "C-u C-c C-a writes the IR it was built from" + (and (string-match-p "\\`; LLVM IR for step" text) + (string-match-p "^define .*flan\\.step" text))) + ;; Nothing has been evaluated into this daemon, so the body in the + ;; cell is still the one the process was launched with — the one case + ;; where what is installed *now* is knowable, and it says so. + (test-flan--check "and says the program is still running the host's copy" + (string-match-p "host executable" text)))) + + ;; Refused by name rather than shown as an empty buffer. + (test-flan--check "a name the program does not define is refused by name" + (let ((raised nil)) + (condition-case err (flan-disassemble "no-such-thing") + (user-error (setq raised (error-message-string err)))) + (and raised (string-match-p "no function named" raised)))) + (test-flan--check "and so is a global, which has no code to show" + (let ((raised nil)) + (condition-case err (flan-disassemble "ticks") + (user-error (setq raised (error-message-string err)))) + (and raised (string-match-p "not a function" raised)))) + + (flan-dev-quit) + (ignore-errors (delete-file socket3))) + (if (zerop test-flan--failures) (message "flan-dev.el: all tests passed") (message "\n%d failure(s)" test-flan--failures) diff --git a/lib/dev.ml b/lib/dev.ml index 7ec16d6..0cb1dfc 100644 --- a/lib/dev.ml +++ b/lib/dev.ml @@ -13,6 +13,16 @@ only if it is the session that compiled it. So the daemon launches the program rather than attaching to one. *) +(* Where a function's body was last built. The daemon owns the build, so it is + the only thing that can answer "which module defines this name now" — but + see [basis] below for what that answer honestly is. *) +type origin = { + ogen : int; (* reload generation; 0 is the host's *) + oso : string; (* the object the body was linked into *) + oll : string; (* the IR it was built from *) + oloc : string; (* where the source it came from was written *) +} + type t = { session : Session.t; child : int; (* the running program *) @@ -21,6 +31,12 @@ type t = { stdout : Unix.file_descr; (* the program's output, on its way to here *) out : Buffer.t; (* ...buffered until an editor asks for it *) mutable n : int; (* dlopen caches by path: never reuse one *) + (* Bookkeeping for disassembly, and the reason it can exist at all: the + daemon compiled every module it sent, so the .ll and the .so are on its + own disk. What it does not have is a way back into the process's cells. *) + mutable gen : int; (* accepted deliveries, in order *) + owners : (string, origin) Hashtbl.t; (* fn name -> the last module sent *) + host_ll : string; (* the IR the running program was built from *) } (* The program's stdout is a pipe into this process, so that an editor can see @@ -199,6 +215,46 @@ let alive t = | _ -> false | exception Unix.Unix_error _ -> false +(* ── What a body was built from ─────────────────────────────────────── *) + +let write_file path text = + let oc = open_out_bin path in + Fun.protect ~finally:(fun () -> close_out oc) (fun () -> output_string oc text) + +let read_file path = + let ic = open_in_bin path in + Fun.protect + ~finally:(fun () -> close_in ic) + (fun () -> really_input_string ic (in_channel_length ic)) + +let find_fn t name = + List.find_opt + (fun (f : Tast.fn) -> + String.equal f.Tast.name name && f.Tast.fparent = None) + t.session.Session.program.Tast.fns + +let fn_loc t name = + match find_fn t name with + | Some f -> Loc.to_string f.Tast.floc + | None -> "" + +(* Where the *running process* has this function written, which is not where + the session has it. [Session.eval] replaces the checked program as soon as a + form checks — before the build, before delivery — so a body that checked and + then failed to build leaves the session holding a location in a buffer whose + code never landed. [host] is the program the process was launched from and + nothing mutates it, so it is the only honest answer for a name no module has + been accepted for. *) +let host_loc t name = + match + List.find_opt + (fun (f : Tast.fn) -> + String.equal f.Tast.name name && f.Tast.fparent = None) + t.session.Session.host.Tast.fns + with + | Some f -> Loc.to_string f.Tast.floc + | None -> "" + (* ── Ops ───────────────────────────────────────────────────────────── *) (* Every reply is a plist with a :status, so an editor can dispatch on one key @@ -258,11 +314,24 @@ let eval t ~code ~origin = | c -> t.n <- t.n + 1; let out = Filename.concat t.dir (Printf.sprintf "m%d.so" t.n) in + (* [Build.shared] deletes its own .ll unless asked to keep it, and what it + keeps is in a working directory named after this process rather than + after the module. Writing our own copy beside the .so is what makes + [disassemble] able to show the IR of a body installed ten reloads ago: + nothing else on this machine still has that text. *) + let ll = Filename.concat t.dir (Printf.sprintf "m%d.ll" t.n) in + write_file ll c.Session.ir; (match Build.shared ~opts:{ Build.default with Build.dev = true } ~ir:c.Session.ir ~out () with | timing -> (match deliver t out with | "ok" -> + 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 }) + c.Session.fns; ok [ ":names " ^ Wire.strings c.Session.names; ":fns " ^ Wire.strings c.Session.fns; @@ -441,6 +510,307 @@ let abort t = | exception Unix.Unix_error (e, _, _) -> error ("cannot reach the program: " ^ Unix.error_message e) +(* ── Disassembly ───────────────────────────────────────────────────── *) + +(* [flan emit --dev] can print the IR of a whole source file, which is a + different question from the one an editor asks: not "what would this compile + to" but "what is the code the running program is calling for this name". + Only the daemon can answer that, because it built every module it sent and + still has the .ll and the .so on disk. + + What it cannot do is read a cell back. The agent's socket takes a module + path, [result], [status], [restarts], [restart] and [abort] — there is no + verb that reports an address, [flan_dev_cell] lives in the program's address + space, and an expression evaluated through [eval-expr] renders a pointer as + [] on purpose. So the answer is the last module *delivered* for the + name, and the reply says exactly that rather than implying more; see + [basis]. The one case that is certain is the case where nothing has been + delivered at all, and it says that too. + + SBCL's presentation is worth two things here and not a third. Offsets from + the function's own start rather than file addresses, because an address into + a .so means nothing to a reader; and labels for branch targets inside the + function, which is most of the difference between readable and not. The + third is source interleaving, which SBCL can do because it has the mapping + and this build has no line tables — so it is refused by name in the reply + instead of being faked by printing the listing with no source in it. *) + +let objdump = try Sys.getenv "FLAN_OBJDUMP" with Not_found -> "objdump" + +let run_capture cmd = + let ic = Unix.open_process_in (cmd ^ " 2>&1") in + let b = Buffer.create 4096 in + let chunk = Bytes.create 4096 in + let rec go () = + match input ic chunk 0 4096 with + | 0 -> () + | n -> Buffer.add_subbytes b chunk 0 n; go () + | exception End_of_file -> () + in + go (); + let code = match Unix.close_process_in ic with Unix.WEXITED c -> c | _ -> -1 in + (code, Buffer.contents b) + +let contains hay needle = + let n = String.length needle and h = String.length hay in + let rec go i = i + n <= h && (String.sub hay i n = needle || go (i + 1)) in + n = 0 || go 0 + +(* The IR of one function out of a module's text. [Emit] writes a define's + closing brace at column 0 and nowhere else, so the end is unambiguous + without parsing LLVM. One .ll can carry several bodies — [C-c C-k] sends a + buffer's worth as one module — which is why this slices rather than + returning the file. *) +let ir_of ~ir name = + let sym = Emit.fname name in + let rec take = function + | [] -> [] + | "}" :: _ -> [ "}" ] + | l :: rest -> l :: take rest + in + let rec find = function + | [] -> None + | l :: rest -> + if String.length l > 7 && String.sub l 0 7 = "define " && contains l (sym ^ "(") + then Some (String.concat "\n" (take (l :: rest))) + else find rest + in + find (String.split_on_char '\n' ir) + +(* objdump's own output, rebased and labelled. A line is + [" 250:bytesmnemonic"], with a continuation line carrying only + bytes when an instruction's encoding does not fit the column. *) +type insn = { off : int; bytes : string; text : string } + +let parse_listing ~sym text = + let head = "<" ^ sym ^ ">:" in + let lines = String.split_on_char '\n' text in + let rec drop = function + | [] -> [] + | l :: rest -> if contains l head then rest else drop rest + in + (* objdump prints a blank line after the last instruction of a symbol and + then whatever follows it in the section. Stopping at that line is what + keeps a one-function listing from running into the next function. *) + let rec upto = function + | [] -> [] + | l :: rest -> if String.trim l = "" then [] else l :: upto rest + in + let body = upto (drop lines) in + let base = ref None in + let out = ref [] in + List.iter + (fun l -> + match String.split_on_char '\t' l with + | addr :: bytes :: rest -> + let a = String.trim addr in + let a = + if String.length a > 0 && a.[String.length a - 1] = ':' then + String.sub a 0 (String.length a - 1) + else a + in + (match int_of_string_opt ("0x" ^ a) with + | None -> () + | Some n -> + if !base = None then base := Some n; + let b = match !base with Some b -> b | None -> n in + out := + { off = n - b; bytes = String.trim bytes; + text = String.trim (String.concat "\t" rest) } + :: !out) + | _ -> ()) + body; + (List.rev !out, !base <> None) + +(* A branch inside the function shows as [] or, for the entry, + []. Those become [L0]..[Ln] in address order, as SBCL labels + them; anything else objdump annotated — a cell, a plt entry, another + function — is left exactly as it wrote it. *) +let target_of ~sym text = + if not (contains text ("<" ^ sym)) then None + else + match String.index_opt text '<' with + | None -> None + | Some i -> + let rest = String.sub text i (String.length text - i) in + if String.length rest < 3 || rest.[String.length rest - 1] <> '>' then None + else + let inner = String.sub rest 1 (String.length rest - 2) in + if String.equal inner sym then Some 0 + else + let p = String.length sym in + if String.length inner > p + 1 && String.sub inner 0 (p + 1) = sym ^ "+" + then + int_of_string_opt (String.sub inner (p + 1) (String.length inner - p - 1)) + else None + +let render_listing ~sym insns = + let targets = + List.sort_uniq compare + (List.filter_map (fun i -> target_of ~sym i.text) insns) + in + let label n = + let rec idx k = function + | [] -> None + | x :: r -> if x = n then Some (Printf.sprintf "L%d" k) else idx (k + 1) r + in + idx 0 targets + in + let b = Buffer.create 4096 in + List.iter + (fun i -> + (match label i.off with + | Some lb -> Buffer.add_string b (lb ^ ":\n") + | None -> ()); + let text = + match target_of ~sym i.text with + | Some n -> + (match label n with + | Some lb -> + (* [jmp 1d9 ] becomes [jmp L1]. The bare number + objdump prints is the address the branch encodes *in the + file*, which is the one number on the line that means nothing + once the listing is rebased — so it goes with the symbol it + duplicates. *) + let j = String.index i.text '<' in + let head = String.sub i.text 0 j in + let k = ref (String.length head) in + while !k > 0 && head.[!k - 1] = ' ' do decr k done; + while !k > 0 + && (match head.[!k - 1] with + | '0' .. '9' | 'a' .. 'f' | 'A' .. 'F' -> true + | _ -> false) + do decr k done; + String.sub head 0 !k ^ lb + | None -> i.text) + | None -> i.text + in + if text = "" then + Buffer.add_string b (Printf.sprintf " %04x %s\n" i.off i.bytes) + else + Buffer.add_string b + (Printf.sprintf " %04x %-22s %s\n" i.off i.bytes text)) + insns; + Buffer.contents b + +let asm_of ~obj name = + let sym = "flan." ^ name in + let code, text = + run_capture + (String.concat " " + [ Filename.quote objdump; "-d"; + "--disassemble=" ^ Filename.quote sym; Filename.quote obj ]) + in + if code <> 0 then + Error + (Printf.sprintf "%s failed on %s (exit %d): %s" objdump obj code + (String.trim text)) + else + match parse_listing ~sym text with + | _, false -> Error (Printf.sprintf "%s found no symbol %s in %s" objdump sym obj) + | insns, true -> Ok (render_listing ~sym insns) + +(* Where a name's body was last built, and how much of that is a claim about + the running process rather than about this daemon's disk. *) +let basis t name = + match Hashtbl.find_opt t.owners name with + | None -> + ( { ogen = 0; oso = Filename.concat t.dir "program"; oll = t.host_ll; + oloc = host_loc t name }, + "the host executable — nothing defining this name has been delivered in \ + this session, so the program's cell still holds this body" ) + | Some o -> + let m = Filename.basename o.oso in + ( o, + match state t with + | Stopped c -> + (* Not "so it is not installed yet". The commonest way to stop is to + install a body and have it error, so a stopped program is more + likely to be running this code than not — the daemon simply cannot + read the cell back to find out, and saying otherwise would be the + [ok]-means-probably failure in the one field that exists to prevent + it. What is certain is only the second half. *) + Printf.sprintf + "%s — the last module delivered for this name, accepted for install; \ + the program is stopped on %s and the daemon cannot read the cell \ + back to say whether it installed this before stopping. Nothing \ + further installs until it resumes" + m c + | Running -> + Printf.sprintf + "%s — the last module delivered for this name, accepted for install; \ + the program installs it at its next frame boundary and the daemon \ + cannot read the cell back to confirm that it has" + m + | Unreachable r -> + Printf.sprintf + "%s — the last module delivered for this name; the program is not \ + answering (%s), so whether it installed cannot be said" + m r ) + +let kind_of t name = + let p = t.session.Session.program in + if List.exists (fun (g : Tast.global) -> String.equal g.Tast.gname name) + p.Tast.globals + then Some "a global" + else if + List.exists (fun (e : Tast.extern) -> String.equal e.Tast.ename name) + p.Tast.externs + 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 -> + let o, why = basis t name in + let common = + [ ":name " ^ Wire.quote name; ":form " ^ Wire.quote form; + ":generation " ^ string_of_int o.ogen; + ":signature " ^ Wire.quote (signature_of_fn f); + (* [o.oloc], not the session's: the session moves on as soon as a + form checks, and this has to name the source the code being shown + was built from. *) + ":loc " ^ Wire.quote o.oloc; + ":basis " ^ Wire.quote why ] + in + if form = "ir" then + match read_file o.oll with + | text -> + (match ir_of ~ir:text name with + | Some 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)) + | exception Sys_error 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) + else + match asm_of ~obj:o.oso name with + | Ok text -> + ok + (common + @ [ ":object " ^ Wire.quote o.oso; + ":note " + ^ Wire.quote + "source interleaving needs line tables this build does not \ + emit"; + ":text " ^ Wire.quote text ]) + | Error m -> error m + let handle t req = match Wire.string_field req "op" with | Some "eval" -> @@ -467,6 +837,14 @@ let handle t req = | Some name -> choose t ~name | None -> error "restart needs :name") | Some "abort" -> abort t + | Some "disassemble" -> + (match Wire.string_field req "name" with + | Some name -> + let form = + match Wire.string_field req "form" with Some f -> f | None -> "asm" + in + disassemble t ~name ~form + | None -> error "disassemble needs :name") | Some "close" -> ok [] | Some op -> error ("unknown op: " ^ op) | None -> error "no :op" @@ -511,9 +889,21 @@ let start ~file ~sock = in (try Unix.mkdir dir 0o700 with Unix.Unix_error (Unix.EEXIST, _, _) -> ()); let exe = Filename.concat dir "program" in + (* [keep] so the host's own IR survives the build. It is the text [llc] was + actually given, not a second emission of it, which is the difference + between showing what the process was built from and showing what it + probably was. [Build.executable] leaves it in its own working directory + under the module's basename; it is moved here so that nothing else in this + process can reuse the name. *) ignore - (Build.executable ~opts:{ Build.default with Build.dev = true } + (Build.executable + ~opts:{ Build.default with Build.dev = true; Build.keep = true } ~csrcs:l.Load.csrcs ~lflags:l.Load.lflags session.Session.host ~out:exe); + let host_ll = Filename.concat dir "host.ll" in + (try + Sys.rename (Filename.concat (Build.workdir ()) (Filename.basename exe ^ ".ll")) + host_ll + with Sys_error _ -> ()); let agent = Filename.concat dir "agent.sock" in (* The program's source names some socket path; the daemon is the one that @@ -538,7 +928,8 @@ let start ~file ~sock = end; let t = - { session; child; agent; dir; stdout = rd; out = Buffer.create 4096; n = 0 } + { session; child; agent; dir; stdout = rd; out = Buffer.create 4096; n = 0; + gen = 0; owners = Hashtbl.create 32; host_ll } in (try Unix.unlink sock with Unix.Unix_error _ -> ()); let ls = Unix.socket Unix.PF_UNIX Unix.SOCK_STREAM 0 in diff --git a/test/test_dev.ml b/test/test_dev.ml index 2b5a8fa..911e835 100644 --- a/test/test_dev.ml +++ b/test/test_dev.ml @@ -408,6 +408,295 @@ let () = (try ignore (Unix.waitpid [] bpid) with Unix.Unix_error _ -> ()) end end; + (* ── Disassembly ───────────────────────────────────────────────── *) + + (* 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 + delivered. Its own session rather than a reuse of the first: the first + one's program has been reloaded four times and abandoned by the time it + gets here, and a generation counter tested against a session someone + else drove says nothing. *) + let dsock = tmp "disasm.sock" and dout = tmp "disasm.out" in + (try Sys.remove dsock with Sys_error _ -> ()); + let dfd = Unix.openfile dout [ Unix.O_WRONLY; Unix.O_CREAT; Unix.O_TRUNC ] 0o600 in + let dpid = + Unix.create_process flan + [| flan; "dev"; "programs/dev-repl.flan"; "-s"; dsock |] + Unix.stdin dfd Unix.stderr + in + Unix.close dfd; + if not (await (fun () -> Sys.file_exists dsock)) then begin + fail "the disassembly daemon never listened"; + (try Unix.kill dpid Sys.sigkill with Unix.Unix_error _ -> ()) + end + else begin + let c = connect dsock in + let generation r = + match Wire.field r "generation" with + | Some { Form.v = Form.Int n; _ } -> Some (Int64.to_int n) + | _ -> None + in + let text r = Option.value ~default:"" (Wire.string_field r "text") in + let basis r = Option.value ~default:"" (Wire.string_field r "basis") in + let has hay needle = + let n = String.length needle and h = String.length hay in + let rec go i = i + n <= h && (String.sub hay i n = needle || go (i + 1)) in + n > 0 && go 0 + in + let have_objdump = + Sys.command "command -v objdump > /dev/null 2>&1" = 0 + in + + (* Nothing has been delivered, so the cell still holds the body the + process was launched with. This is the one case where "what is + installed now" is knowable, and the reply has to say so rather than + hedging like the others. *) + let r = request c "(:op \"disassemble\" :name \"step\" :form \"ir\")" in + if status r <> "ok" then + fail "the IR of a name the program was built with: %s" + (Option.value ~default:"" (Wire.string_field r "message")) + else begin + if generation r <> Some 0 then + fail "an untouched name is not generation 0"; + if not (has (text r) "define") || not (has (text r) "flan.step") then + fail "the IR of step is not a define of it: %S" (text r); + (* One function, not the module: dev-repl.flan defines [main] too, and + a slice that ran past its own closing brace would carry it. *) + if has (text r) "flan.main" then + fail "the IR of step carried another function with it"; + if not (has (basis r) "host executable") then + fail "an untouched name does not say it is the host's: %S" (basis r) + end; + + (* Delivering one moves the ownership, and with it everything the reply + derives from it: the generation, the object, the location the body was + typed at, and what the answer is now allowed to claim. *) + let r = + request c + "(:op \"eval\" :code \"(defn step [] i64 (set ticks (+ ticks 7)) ticks)\" :file \"/tmp/disasm.flan\")" + in + if status r <> "ok" then + fail "installing a body to disassemble: %s" + (Option.value ~default:"" (Wire.string_field r "message")) + else begin + let r = request c "(:op \"disassemble\" :name \"step\" :form \"ir\")" in + if status r <> "ok" then + fail "the IR of a redefined name: %s" + (Option.value ~default:"" (Wire.string_field r "message")) + else begin + if generation r <> Some 1 then + fail "a redefined name is not generation 1: %s" + (match generation r with Some n -> string_of_int n | None -> "none"); + (* The body that was just sent, not the one the program was built + with — the two differ only in the constant. *) + if not (has (text r) "7") then + fail "the IR shown is not the body that was delivered: %S" (text r); + if Wire.string_field r "loc" <> Some "/tmp/disasm.flan:1:7" then + fail "the location is not where the new body was typed: %s" + (Option.value ~default:"" (Wire.string_field r "loc")); + match Wire.string_field r "object" with + | Some o when Filename.check_suffix o ".ll" -> () + | o -> + fail "the IR did not come from a .ll: %s" (Option.value ~default:"" o) + end; + (* The honesty rule, and the whole reason this op is not allowed to say + "installed": the daemon delivered a module and the agent queued it, + which is not the same as the game thread having stored it into a + cell — and there is no verb that would let the daemon find out. *) + let r = request c "(:op \"disassemble\" :name \"step\" :form \"ir\")" in + if has (basis r) "host executable" then + fail "a delivered body still claims to be the host's"; + if not (has (basis r) "cannot read the cell back") + && not (has (basis r) "not installed yet") + && not (has (basis r) "cannot be said") + then fail "a delivered body claims more than delivery: %S" (basis r) + end; + + if not have_objdump then + print_endline "dev: disassembly skipped (no objdump on PATH)" + else begin + let r = request c "(:op \"disassemble\" :name \"step\" :form \"asm\")" in + if status r <> "ok" then + fail "the machine code of a redefined name: %s" + (Option.value ~default:"" (Wire.string_field r "message")) + else begin + (* Offsets from the function's own start, SBCL's way: an address into + a .so is the one number on the line a reader cannot use. The first + instruction is therefore at 0000 whatever the object's layout. *) + if not (has (text r) " 0000 ") then + fail "the listing is not rebased to the function's start: %S" (text r); + if not (has (text r) "ret") then + fail "the listing has no instructions in it: %S" (text r); + (* Not faked. There are no line tables in this build, so the reply + says that rather than printing a listing with no source in it. *) + if not (has (Option.value ~default:"" (Wire.string_field r "note")) + "line tables") + then fail "the listing does not say why there is no source in it"; + match Wire.string_field r "object" with + | Some o when Filename.check_suffix o ".so" -> () + | o -> fail "the code did not come from a .so: %s" + (Option.value ~default:"" o) + end; + (* The other presentation borrow, and the one that needs a body with + somewhere to jump to: a branch inside the function reads as [L0] + rather than as an address into an object nobody will open. *) + let r = + request c + "(:op \"eval\" :code \"(defn wind [n i32] i32 (let [acc 0] (dotimes [i n] (set acc (+ acc i))) acc))\" :file \"/tmp/disasm.flan\")" + in + if status r <> "ok" then + fail "installing a body with a loop in it: %s" + (Option.value ~default:"" (Wire.string_field r "message")) + else + let r = request c "(:op \"disassemble\" :name \"wind\" :form \"asm\")" in + if status r <> "ok" then + fail "the machine code of a loop: %s" + (Option.value ~default:"" (Wire.string_field r "message")) + else if not (has (text r) "L0:") then + fail "a branch target is not labelled: %S" (text r) + else if has (text r) " "error" then fail "%s was not refused" what + else + match Wire.string_field r "message" with + | Some m when has m wanted -> () + | m -> + fail "%s was refused for the wrong reason: %s" what + (Option.value ~default:"" m) + in + refused "a global" "(:op \"disassemble\" :name \"ticks\" :form \"asm\")" + "not a function"; + refused "a name nothing defines" + "(:op \"disassemble\" :name \"no-such-fn\" :form \"asm\")" + "no function named"; + refused "a form that is neither ir nor asm" + "(:op \"disassemble\" :name \"step\" :form \"pdf\")" + "\"ir\" or"; + refused "a request with no name" "(:op \"disassemble\" :form \"asm\")" + "needs :name"; + + (* 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 + basis must not say here is "not installed yet" — it would be asserting + non-installation in exactly the case where the body is running. *) + let stopped r = + match Wire.field r "stopped" with + | Some { Form.v = Form.Sym "t"; _ } -> true + | _ -> false + in + let r = + request c + "(:op \"eval\" :code \"(defn step [] i64 (error (Missing {:id 3})))\" :file \"/tmp/disasm.flan\")" + in + if status r <> "ok" then + fail "installing a body that errors: %s" + (Option.value ~default:"" (Wire.string_field r "message")) + else if + not (await (fun () -> stopped (request c "(:op \"describe\")"))) + then fail "the program never stopped on the body that errors" + else begin + let r = request c "(:op \"disassemble\" :name \"step\" :form \"ir\")" in + if status r <> "ok" then + fail "disassembling while the program is stopped: %s" + (Option.value ~default:"" (Wire.string_field r "message")) + else begin + if not (has (basis r) "stopped on Missing") then + fail "a stopped program is not mentioned in the basis: %S" (basis r); + if has (basis r) "not installed" then + fail "a stopped program is said not to have installed: %S" (basis r) + end + end; + + ignore (request c "(:op \"close\")"); + Unix.close c; + if not + (await ~ms:5000 (fun () -> + match Unix.waitpid [ Unix.WNOHANG ] dpid with + | 0, _ -> false + | _ -> true + | exception Unix.Unix_error _ -> true)) + then begin + (try Unix.kill dpid Sys.sigkill with Unix.Unix_error _ -> ()); + (try ignore (Unix.waitpid [] dpid) with Unix.Unix_error _ -> ()) + end + end; + List.iter (fun f -> try Sys.remove f with Sys_error _ -> ()) [ dsock; dout ]; + + (* ── A location that survives an evaluation that did not land ───── *) + + (* [Session.eval] replaces the checked program the moment a form checks, + which is before the build and before delivery. So there is a window in + which the session holds a body the running process has never seen, and a + disassembly that took its source location from the session would point + into the buffer of code that never landed — while showing the host's + code and saying, correctly, that nothing had been delivered. One reply + contradicting itself in two fields. + + A daemon whose [llc] is [false] reproduces it exactly and cheaply: the + host is built by clang and runs, every redefinition checks and then + fails to build, and nothing is ever delivered. *) + let ssock = tmp "stale.sock" and sout = tmp "stale.out" in + (try Sys.remove ssock with Sys_error _ -> ()); + let sfd = Unix.openfile sout [ Unix.O_WRONLY; Unix.O_CREAT; Unix.O_TRUNC ] 0o600 in + let env = + Array.append (Unix.environment ()) [| "FLAN_LLC=false" |] + in + let spid = + Unix.create_process_env flan + [| flan; "dev"; "programs/dev-repl.flan"; "-s"; ssock |] + env Unix.stdin sfd Unix.stderr + in + Unix.close sfd; + if not (await (fun () -> Sys.file_exists ssock)) then begin + fail "the daemon with no working llc never listened"; + (try Unix.kill spid Sys.sigkill with Unix.Unix_error _ -> ()) + end + else begin + let c = connect ssock in + let has hay needle = + let n = String.length needle and h = String.length hay in + let rec go i = i + n <= h && (String.sub hay i n = needle || go (i + 1)) in + n > 0 && go 0 + in + let r = + request c + "(:op \"eval\" :code \"(defn step [] i64 (set ticks (+ ticks 9)) ticks)\" :file \"/tmp/never-landed.flan\")" + in + if status r <> "error" then + fail "an evaluation that cannot be built was reported as installed"; + let r = request c "(:op \"disassemble\" :name \"step\" :form \"ir\")" in + if status r <> "ok" then + fail "disassembling after a build that failed: %s" + (Option.value ~default:"" (Wire.string_field r "message")) + else begin + let loc = Option.value ~default:"" (Wire.string_field r "loc") in + if has loc "never-landed" then + fail "the location is a buffer whose code was never delivered: %s" loc; + if not (has loc "dev-repl.flan") then + fail "the location is not the source the process was built from: %s" loc + end; + ignore (request c "(:op \"close\")"); + Unix.close c; + if not + (await ~ms:5000 (fun () -> + match Unix.waitpid [ Unix.WNOHANG ] spid with + | 0, _ -> false + | _ -> true + | exception Unix.Unix_error _ -> true)) + then begin + (try Unix.kill spid Sys.sigkill with Unix.Unix_error _ -> ()); + (try ignore (Unix.waitpid [] spid) with Unix.Unix_error _ -> ()) + end + end; + List.iter (fun f -> try Sys.remove f with Sys_error _ -> ()) [ ssock; sout ]; + List.iter (fun f -> try Sys.remove f with Sys_error _ -> ()) [ sock; out; bsock; bout ]; if !failures = 0 then print_endline "dev: all tests passed"