JosephFerano/flan
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Merge branch 'disasm-overlay' into dev-loop

Browse Source
This commit is contained in:
Joseph Ferano 2026-09-12 04:10:54 +07:00
commit d336da65e5
6 changed files with 970 additions and 14 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

44
NEXT.md
View File

@ -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.<name>` 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 `<ptr>` 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

168
emacs/flan-dev.el
View File

@ -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

4
emacs/flan-mode.el
View File

@ -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)

84
emacs/test-flan-dev.el
View File

@ -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)

395
lib/dev.ml
View File

@ -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
[<ptr>] 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:<tab>bytes<tab>mnemonic"], 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 [<flan.step+0x79>] or, for the entry,
[<flan.step>]. 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 <flan.step+0x89>] 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

289
test/test_dev.ml
View File

@ -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) "<flan.wind+" then
fail "a branch still names the function it is inside: %S" (text r)
end;
(* Refused by name, each for its own reason: [ok] would have to mean
"probably" otherwise. *)
let refused what req wanted =
let r = request c req in
if status 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"