Show the code a name last compiled to, and say what that claims
An editor could see the IR of a whole file and nothing at all of what the running process is executing. The daemon built every module it sent, so objdump on the right object is the disassembly and the retained .ll is the IR; the only hard part is which module owns a name after N reloads, and a table filled on accepted delivery answers it. What it deliberately does not claim is that the code shown is installed. The agent takes a module path and answers ok when it has queued one; there is no verb that reads a cell back, so :basis spells out which of the three things is true — the host's body, still certain because nothing was ever delivered; queued and awaiting a frame boundary; or queued while the program is stopped and therefore certainly not installed yet. From SBCL: offsets from the function's start rather than addresses into a file, and L0.. labels on branch targets. Not source interleaving, which needs line tables this build does not emit, so the reply says so.
This commit is contained in:
parent
bd5892eccd
commit
c688992ac9
298
lib/dev.ml
298
lib/dev.ml
@ -493,6 +493,296 @@ 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 = fn_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 ->
|
||||
Printf.sprintf
|
||||
"%s — delivered and accepted, but the program is stopped on %s and \
|
||||
has not reached a frame boundary since, so this is not installed yet"
|
||||
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);
|
||||
":loc " ^ Wire.quote (Loc.to_string f.Tast.floc);
|
||||
":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" ->
|
||||
@ -519,6 +809,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"
|
||||
|
||||
Loading…
x
Reference in New Issue
Block a user