diff --git a/lib/dev.ml b/lib/dev.ml index 69695e6..9f0f3da 100644 --- a/lib/dev.ml +++ b/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 + [] 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 = 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"