A source heading escapes control characters, names its file by the path it was given, and quotes a form cut at a character boundary
This commit is contained in:
parent
573076994e
commit
40bd96ec65
@ -206,34 +206,104 @@ what the IR section compiles to."
|
||||
;; each function with a map from byte offsets to forms, which the assembler
|
||||
;; ignores and which is read here out of the assembly it was given.
|
||||
|
||||
(defun flan-lower--split-where (where)
|
||||
"WHERE, a heading's \"file:line:col\", as (FILE LINE COL), or nil.
|
||||
The file is everything before the last two colons, so a name holding a colon
|
||||
or a space survives."
|
||||
(when (string-match "\\`\\(.*\\):\\([0-9]+\\):\\([0-9]+\\)\\'" where)
|
||||
(list (match-string 1 where)
|
||||
(string-to-number (match-string 2 where))
|
||||
(string-to-number (match-string 3 where)))))
|
||||
|
||||
(defun flan-lower--shown (where)
|
||||
"WHERE as a listing shows it: the file by its base name."
|
||||
(pcase (flan-lower--split-where where)
|
||||
(`(,file ,line ,col) (format "%s:%d:%d" (file-name-nondirectory file) line col))
|
||||
(_ where)))
|
||||
|
||||
(defun flan-lower--comment-text (s)
|
||||
"S with its control characters escaped, as `flan emit' writes a file name."
|
||||
(replace-regexp-in-string
|
||||
"[\x00-\x1f\x7f]"
|
||||
(lambda (c)
|
||||
(pcase (aref c 0)
|
||||
(?\n "\\\\n") (?\r "\\\\r") (?\t "\\\\t")
|
||||
(ch (format "\\\\x%02x" ch))))
|
||||
s t))
|
||||
|
||||
(defun flan-lower--same-file (table heading)
|
||||
"Whether TABLE, a path from a line table, names the file HEADING names.
|
||||
The line table's path may have been made absolute where the heading's is the
|
||||
one the program was given, so a trailing run of whole components counts."
|
||||
(let ((table (flan-lower--comment-text table)))
|
||||
(or (equal table heading)
|
||||
(and (< (length heading) (length table))
|
||||
(string-suffix-p (concat "/" heading) table)))))
|
||||
|
||||
(defun flan-lower--headings (ir)
|
||||
"A table of position (\"file:line:col\") to form, from the comments in IR."
|
||||
"The headings in IR, as a table of (LINE . COL) to a list of (FILE . FORM).
|
||||
A heading is `; form', padding, a tab and its position; the tab is the one
|
||||
character neither half can hold."
|
||||
(let ((tbl (make-hash-table :test #'equal)))
|
||||
(dolist (l (split-string ir "\n"))
|
||||
(when (string-match
|
||||
"\\`[ \t]*; \\(.*[^ ]\\) +\\([^ ]+:[0-9]+:[0-9]+\\)\\'" l)
|
||||
(when (string-match "\\`[ \t]*; \\([^\t]*\\)\t\\(.*\\)\\'" l)
|
||||
;; Both taken before `string-trim', which matches a regexp of its own.
|
||||
(let* ((where (match-string 2 l))
|
||||
(form (string-trim (match-string 1 l))))
|
||||
(unless (gethash where tbl) (puthash where form tbl)))))
|
||||
(pcase (flan-lower--split-where where)
|
||||
(`(,file ,line ,col)
|
||||
(push (cons file form) (gethash (cons line col) tbl)))))))
|
||||
tbl))
|
||||
|
||||
(defun flan-lower--annotate-llc (text headings)
|
||||
(defun flan-lower--unoctal (s)
|
||||
"S, a string from an assembler directive, with its octal escapes decoded."
|
||||
(replace-regexp-in-string
|
||||
"\\\\\\([0-7]\\{3\\}\\|\\\\\\|\"\\)"
|
||||
(lambda (m)
|
||||
(let ((e (substring m 1)))
|
||||
(if (string-match-p "\\`[0-7]\\{3\\}\\'" e)
|
||||
(string (string-to-number e 8))
|
||||
e)))
|
||||
s t t))
|
||||
|
||||
(defun flan-lower--files (asm)
|
||||
"The `.file' table of ASM, `llc' output: file number to path."
|
||||
(let ((tbl (make-hash-table)))
|
||||
(dolist (l (split-string asm "\n"))
|
||||
(when (string-match
|
||||
"\\`[ \t]*\\.file[ \t]+\\([0-9]+\\)[ \t]+\"\\(\\(?:[^\"\\]\\|\\\\.\\)*\\)\"\\(?:[ \t]+\"\\(\\(?:[^\"\\]\\|\\\\.\\)*\\)\"\\)?" l)
|
||||
(let* ((n (string-to-number (match-string 1 l)))
|
||||
(a (flan-lower--unoctal (match-string 2 l)))
|
||||
(b (and (match-string 3 l) (flan-lower--unoctal (match-string 3 l)))))
|
||||
(puthash n (cond ((null b) a)
|
||||
((file-name-absolute-p b) b)
|
||||
(t (concat (file-name-as-directory a) b)))
|
||||
tbl))))
|
||||
tbl))
|
||||
|
||||
(defun flan-lower--annotate-llc (text headings files)
|
||||
"TEXT, `llc' output with a line table, with each position written as its form.
|
||||
A `.loc' whose position has a form in HEADINGS becomes a comment quoting it,
|
||||
unless it names the form just quoted; the directives, and the labels the line
|
||||
table alone needed, are dropped."
|
||||
A `.loc' whose file (looked up in FILES, the `.file' table) and position have
|
||||
a form in HEADINGS becomes a comment quoting it, unless it names the form just
|
||||
quoted; the directives, and the labels the line table alone needed, are
|
||||
dropped."
|
||||
(let ((last nil) (out nil))
|
||||
(dolist (l (split-string text "\n"))
|
||||
(cond
|
||||
((string-match "\\`[ \t]*\\.loc\\b\\(?:.*# \\([^ ]*:[0-9]+:[0-9]+\\)[ \t]*\\'\\)?" l)
|
||||
(let ((form (and (match-string 1 l)
|
||||
(gethash (match-string 1 l) headings))))
|
||||
((string-match "\\`[ \t]*\\.loc[ \t]+\\([0-9]+\\)[ \t]+\\([0-9]+\\)[ \t]+\\([0-9]+\\)" l)
|
||||
(let* ((path (gethash (string-to-number (match-string 1 l)) files))
|
||||
(line (string-to-number (match-string 2 l)))
|
||||
(col (string-to-number (match-string 3 l)))
|
||||
(hit (and path
|
||||
(seq-find (lambda (h) (flan-lower--same-file path (car h)))
|
||||
(gethash (cons line col) headings))))
|
||||
(form (cdr hit)))
|
||||
(when (and form (not (equal form last)))
|
||||
(setq last form)
|
||||
(push (format "\t# %s%s%s" form
|
||||
(make-string (max 1 (- 56 (length form))) ?\s)
|
||||
(match-string 1 l))
|
||||
(format "%s:%d:%d"
|
||||
(file-name-nondirectory (car hit)) line col))
|
||||
out))))
|
||||
((string-match-p "\\`\\(\\.Ltmp[0-9]+\\|\\.Lfunc_begin[0-9]+\\):\\'" l))
|
||||
((string-match-p "\\`[ \t]*\\.file[ \t]+[0-9]" l))
|
||||
@ -271,7 +341,7 @@ the function's first byte, indented by how deeply it is nested."
|
||||
(head (format "\t%s# %s" (make-string (* 2 depth) ?\s)
|
||||
form)))
|
||||
(push (concat head (make-string (max 1 (- 62 (length head))) ?\s)
|
||||
where)
|
||||
(flan-lower--shown where))
|
||||
out))))))
|
||||
(push l out))
|
||||
(string-join (nreverse out) "\n")))
|
||||
@ -296,11 +366,13 @@ prelude is emitted too, so a two-line program is ten thousand lines of IR."
|
||||
ll "-o" s))
|
||||
;; `.size' ends the function in GAS output, and it is the last line
|
||||
;; of it rather than the first line of the next.
|
||||
(let ((text (flan-lower--narrow (flan-lower--slurp s)
|
||||
(concat "^\"?" sym "\"?:") "\\.size")))
|
||||
(let* ((asm (flan-lower--slurp s))
|
||||
(text (flan-lower--narrow asm (concat "^\"?" sym "\"?:")
|
||||
"\\.size")))
|
||||
(and text
|
||||
(flan-lower--annotate-llc
|
||||
text (flan-lower--headings (flan-lower--slurp ll)))))))
|
||||
text (flan-lower--headings (flan-lower--slurp ll))
|
||||
(flan-lower--files asm))))))
|
||||
('x86
|
||||
(let ((dis (expand-file-name "out.x86.dis" (flan-lower--scratch))))
|
||||
(unless (file-exists-p dis)
|
||||
|
||||
@ -1762,7 +1762,7 @@ already rely on it — so nothing here is a stand-in for the real thing."
|
||||
(test-flan--check "and says the program is still running the host's copy"
|
||||
(string-match-p "host executable" text))
|
||||
(test-flan--check "and the IR is headed by the forms it came from"
|
||||
(string-match-p "^ *; (set ticks (\\+ ticks 1)) +dev-repl\\.flan:[0-9]+:3$"
|
||||
(string-match-p "^ *; (set ticks (\\+ ticks 1)) *\t[^\n]*dev-repl\\.flan:[0-9]+:3$"
|
||||
text))))
|
||||
|
||||
;; Refused by name rather than shown as an empty buffer.
|
||||
@ -1975,7 +1975,7 @@ already rely on it — so nothing here is a stand-in for the real thing."
|
||||
(dolist (s '(ir O0 O2 x86))
|
||||
(test-flan--check (format "the %s section is headed by the source" s)
|
||||
(string-match-p
|
||||
"[;#] (set ticks (\\+ ticks 1)) +[^ \n]*dev-repl\\.flan:[0-9]+:3\n."
|
||||
"[;#] (set ticks (\\+ ticks 1))[ \t]+[^\n]*dev-repl\\.flan:[0-9]+:3\n."
|
||||
(alist-get s flan-lower--texts)))))
|
||||
;; `r' is the other half of the caching claim: one section redrawn,
|
||||
;; and the IR every section is downstream of left where it was. The
|
||||
|
||||
65
lib/dev.ml
65
lib/dev.ml
@ -3504,50 +3504,71 @@ let src_line ~depth ~where form =
|
||||
let head = Printf.sprintf "; %s%s" (String.make (2 * depth) ' ') form in
|
||||
head ^ String.make (max 1 (60 - String.length head)) ' ' ^ where
|
||||
|
||||
(* A position as a listing shows it: the file by its base name, since the
|
||||
listing is of one function and a whole path would push the form off the
|
||||
line. *)
|
||||
let shown where =
|
||||
match Emit.split_where where with
|
||||
| Some (file, line, col) ->
|
||||
Printf.sprintf "%s:%d:%d" (Filename.basename file) line col
|
||||
| None -> where
|
||||
|
||||
(* The x86 backend's source map for [name], out of the assembly the module was
|
||||
built from. *)
|
||||
let x86_source ~asm name =
|
||||
List.map
|
||||
(fun (off, depth, where, form) -> (off, src_line ~depth ~where form))
|
||||
(fun (off, depth, where, form) -> (off, src_line ~depth ~where:(shown where) form))
|
||||
(X86.read_srcmap ~asm (Mangle.sym name))
|
||||
|
||||
(* The headings [Emit] wrote into a [.ll], by file and line: for each line the
|
||||
outermost form written on it, which is the one with the smallest column. *)
|
||||
(* The headings [Emit] wrote into a [.ll], by line: every [(file, column,
|
||||
form)] written on it. A heading is [; form], padding, a tab and the
|
||||
position; a tab is the one character neither half can hold. *)
|
||||
let ll_headings ir =
|
||||
let tbl = Hashtbl.create 64 in
|
||||
List.iter
|
||||
(fun l ->
|
||||
let l = String.trim l in
|
||||
if String.length l > 2 && l.[0] = ';' then
|
||||
match String.rindex_opt l ' ' with
|
||||
match String.index_opt l '\t' with
|
||||
| None -> ()
|
||||
| Some i ->
|
||||
let form = String.trim (String.sub l 1 (i - 1)) in
|
||||
let where = String.sub l (i + 1) (String.length l - i - 1) in
|
||||
let form = String.trim (String.sub l 1 i) in
|
||||
(match String.split_on_char ':' where with
|
||||
| [ file; line; col ] ->
|
||||
(match int_of_string_opt line, int_of_string_opt col with
|
||||
| Some line, Some col ->
|
||||
let key = (file, line) in
|
||||
(match Hashtbl.find_opt tbl key with
|
||||
| Some (c, _) when c <= col -> ()
|
||||
| _ -> Hashtbl.replace tbl key (col, form))
|
||||
| _ -> ())
|
||||
| _ -> ()))
|
||||
(match Emit.split_where where with
|
||||
| Some (file, line, col) ->
|
||||
let have = Option.value ~default:[] (Hashtbl.find_opt tbl line) in
|
||||
Hashtbl.replace tbl line ((file, col, form) :: have)
|
||||
| None -> ()))
|
||||
(String.split_on_char '\n' ir);
|
||||
tbl
|
||||
|
||||
(* A line table's rows as source lines: the form is looked up in the [.ll]'s
|
||||
headings, and a line with no heading is named by its position alone. *)
|
||||
(* Whether the path a line table gives names the file a heading names. The
|
||||
line table's may have been made absolute where the heading's was written as
|
||||
the program named it, so a heading's path that is a trailing run of whole
|
||||
components of the table's is the same file. *)
|
||||
let same_file ~table heading =
|
||||
let table = Emit.comment_text table in
|
||||
String.equal table heading
|
||||
|| (let n = String.length heading and m = String.length table in
|
||||
n < m
|
||||
&& String.sub table (m - n) n = heading
|
||||
&& table.[m - n - 1] = '/')
|
||||
|
||||
(* A line table's rows as source lines. The form for a row is the outermost
|
||||
heading written on its line of its file, which is the one with the smallest
|
||||
column; a line with no heading is named by its position alone. *)
|
||||
let llvm_source ~ir marks =
|
||||
let tbl = ll_headings ir in
|
||||
List.map
|
||||
(fun (off, file, line) ->
|
||||
let base = Filename.basename file in
|
||||
let where = Printf.sprintf "%s:%d" base line in
|
||||
match Hashtbl.find_opt tbl (base, line) with
|
||||
| Some (_, form) -> (off, src_line ~depth:0 ~where form)
|
||||
| None -> (off, "; " ^ where))
|
||||
let where = Printf.sprintf "%s:%d" (Filename.basename file) line in
|
||||
let here =
|
||||
List.filter (fun (f, _, _) -> same_file ~table:file f)
|
||||
(Option.value ~default:[] (Hashtbl.find_opt tbl line))
|
||||
in
|
||||
match List.sort (fun (_, a, _) (_, b, _) -> compare a b) here with
|
||||
| (_, _, form) :: _ -> (off, src_line ~depth:0 ~where:(Emit.comment_text where) form)
|
||||
| [] -> (off, "; " ^ Emit.comment_text where))
|
||||
marks
|
||||
|
||||
let render_listing ?(src = []) ~sym insns =
|
||||
|
||||
53
lib/emit.ml
53
lib/emit.ml
@ -1995,18 +1995,60 @@ let atomic (e : Tast.expr) =
|
||||
|
||||
(* The heading's two halves: the form's text, with the macro it came out of if
|
||||
it did, and its position. *)
|
||||
(* Text made safe to put in a one-line comment of either language. A comment
|
||||
ends at a newline, and a file name or a source line can hold one, or a
|
||||
carriage return, or any other control character; each is written as an
|
||||
escape instead. Tab is escaped too, because the headings use it as the one
|
||||
separator that can appear in neither half. *)
|
||||
let comment_text s =
|
||||
let unsafe c = Char.code c < 0x20 || Char.code c = 0x7f in
|
||||
if not (String.exists unsafe s) then s
|
||||
else begin
|
||||
let b = Buffer.create (String.length s + 8) in
|
||||
String.iter
|
||||
(fun c ->
|
||||
match c with
|
||||
| '\n' -> Buffer.add_string b "\\n"
|
||||
| '\r' -> Buffer.add_string b "\\r"
|
||||
| '\t' -> Buffer.add_string b "\\t"
|
||||
| c when unsafe c -> Buffer.add_string b (Printf.sprintf "\\x%02x" (Char.code c))
|
||||
| c -> Buffer.add_char b c)
|
||||
s;
|
||||
Buffer.contents b
|
||||
end
|
||||
|
||||
(* The heading's two halves, each safe for a comment: the form's text, with the
|
||||
macro it came out of if it did, and its position. The position names the
|
||||
file as the location does rather than by its base name, because two
|
||||
packages can each have a file of the same name. *)
|
||||
let heading (loc : Loc.t) =
|
||||
match Loc.snippet loc with
|
||||
| None -> None
|
||||
| Some src ->
|
||||
let where = Printf.sprintf "%s:%d:%d" (Filename.basename loc.Loc.file)
|
||||
loc.Loc.line loc.Loc.col in
|
||||
let where = Printf.sprintf "%s:%d:%d" loc.Loc.file loc.Loc.line loc.Loc.col in
|
||||
let src =
|
||||
match loc.Loc.macro with
|
||||
| Some m -> Printf.sprintf "%s [from the macro %s]" src m
|
||||
| None -> src
|
||||
in
|
||||
Some (where, src)
|
||||
Some (comment_text where, comment_text src)
|
||||
|
||||
(* A heading's position read back: the file, the line and the column. The file
|
||||
is everything before the last two colons, so a name with a colon or a space
|
||||
in it survives. *)
|
||||
let split_where where =
|
||||
match String.rindex_opt where ':' with
|
||||
| None -> None
|
||||
| Some j ->
|
||||
(match String.rindex_from_opt where (j - 1) ':' with
|
||||
| None -> None
|
||||
| Some i ->
|
||||
(match
|
||||
int_of_string_opt (String.sub where (i + 1) (j - i - 1)),
|
||||
int_of_string_opt (String.sub where (j + 1) (String.length where - j - 1))
|
||||
with
|
||||
| Some line, Some col -> Some (String.sub where 0 i, line, col)
|
||||
| _ -> None))
|
||||
|
||||
let aserial = ref 0
|
||||
|
||||
@ -2025,8 +2067,11 @@ let annot f (e : Tast.expr) =
|
||||
let head =
|
||||
Printf.sprintf " ; %s%s" (String.make (2 * min 12 f.adepth) ' ') src
|
||||
in
|
||||
(* A tab before the position, which is what [Dev.ll_headings] splits
|
||||
on: neither half can hold one. *)
|
||||
let pad = max 1 (64 - String.length head) in
|
||||
f.aq <- f.aq @ [ (!aserial, head ^ String.make pad ' ' ^ where ^ "\n") ];
|
||||
f.aq <-
|
||||
f.aq @ [ (!aserial, head ^ String.make pad ' ' ^ "\t" ^ where ^ "\n") ];
|
||||
Some (!aserial, prev)
|
||||
end
|
||||
|
||||
|
||||
@ -363,7 +363,13 @@ let snippet ?(lim = 64) (t : t) =
|
||||
raw;
|
||||
let s = Buffer.contents b in
|
||||
if s = "" then None
|
||||
else if String.length s > lim then Some (String.sub s 0 (max 1 (lim - 1)) ^ "…")
|
||||
else if String.length s > lim then begin
|
||||
(* Cut at a character boundary: a UTF-8 continuation byte is 10xxxxxx,
|
||||
and a cut before one would leave half a character behind. *)
|
||||
let n = ref (max 1 (lim - 1)) in
|
||||
while !n > 1 && Char.code s.[!n] land 0xc0 = 0x80 do decr n done;
|
||||
Some (String.sub s 0 !n ^ "…")
|
||||
end
|
||||
else if t.eline > t.line then Some (s ^ " …")
|
||||
else Some s
|
||||
|
||||
|
||||
@ -853,7 +853,7 @@ let wrap ~pre ~width s =
|
||||
let lines = ref [] and cur = Buffer.create 80 in
|
||||
let emit () =
|
||||
if Buffer.length cur > 0 then begin
|
||||
lines := (pre ^ Buffer.contents cur) :: !lines;
|
||||
lines := (pre ^ Emit.comment_text (Buffer.contents cur)) :: !lines;
|
||||
Buffer.clear cur
|
||||
end
|
||||
in
|
||||
@ -3544,7 +3544,10 @@ let frame_map (md : Emit.m) (fn : Tast.fn) ~slots ~fixed ~total ~outgoing
|
||||
~xfer_off ~sret_off ~retval ~dframe ~dslotv ~sret ~sret_at ~param_at
|
||||
~env_at ~xfer_at =
|
||||
let b = Buffer.create 1024 in
|
||||
let line s = Buffer.add_string b (if s = "" then "#\n" else "# " ^ s ^ "\n") in
|
||||
let line s =
|
||||
Buffer.add_string b
|
||||
(if s = "" then "#\n" else "# " ^ Emit.comment_text s ^ "\n")
|
||||
in
|
||||
(* The prose paragraphs wrap; the table below does not, because its columns
|
||||
are the point of it. *)
|
||||
let para s = List.iter (fun l -> Buffer.add_string b (l ^ "\n"))
|
||||
|
||||
2
test/programs/pkgs/twin-a/util.flan
Normal file
2
test/programs/pkgs/twin-a/util.flan
Normal file
@ -0,0 +1,2 @@
|
||||
;;;; One of two packages whose only file is util.flan; see twins.flan.
|
||||
(defn twin [x i32] i32 (* x 3))
|
||||
2
test/programs/pkgs/twin-b/util.flan
Normal file
2
test/programs/pkgs/twin-b/util.flan
Normal file
@ -0,0 +1,2 @@
|
||||
;;;; One of two packages whose only file is util.flan; see twins.flan.
|
||||
(defn twin [x i32] i32 (+ x 7))
|
||||
10
test/programs/twins.flan
Normal file
10
test/programs/twins.flan
Normal file
@ -0,0 +1,10 @@
|
||||
;;;; Two packages, each with a file called util.flan and a function at the
|
||||
;;;; same line and column of it: the source annotation of a disassembly has to
|
||||
;;;; tell the two files apart (test_dev.ml).
|
||||
|
||||
(import twin-a "pkgs/twin-a")
|
||||
(import twin-b "pkgs/twin-b")
|
||||
|
||||
(defn main [] i32
|
||||
(print (+ (twin-a/twin 1) (twin-b/twin 2)))
|
||||
0)
|
||||
@ -3626,6 +3626,76 @@ let () =
|
||||
[ al; bl; ao; bo; as_; bs; aso; bso; dl; dob ]
|
||||
end;
|
||||
|
||||
(* A file name is quoted in every heading, and a name may hold a newline or
|
||||
a carriage return, which would end the comment it is in and leave the
|
||||
rest of the name to the assembler as code. *)
|
||||
if have "llc" && have "as" then begin
|
||||
let odd = tmp "odd\nna\rme.flan" in
|
||||
let src = Build.read_file "programs/annotate.flan" in
|
||||
let oc = open_out_bin odd in
|
||||
output_string oc src;
|
||||
close_out oc;
|
||||
let p = Test_support.checked odd in
|
||||
let files = ref [ odd ] in
|
||||
let compiles what text cmd ext =
|
||||
let f = tmp ("odd-out" ^ ext) and o = tmp "odd-out.o" in
|
||||
files := f :: o :: !files;
|
||||
let oc = open_out_bin f in
|
||||
output_string oc text;
|
||||
close_out oc;
|
||||
if Sys.command (Printf.sprintf cmd (Filename.quote f) (Filename.quote o)
|
||||
^ " > /dev/null 2>&1") <> 0
|
||||
then fail "annotate: %s does not compile when the file name holds LF and CR" what
|
||||
in
|
||||
compiles "the annotated IR" (Emit.program ~annotate:true p)
|
||||
"llc -O0 -filetype=obj %s -o %s" ".ll";
|
||||
compiles "the annotated debug IR" (Emit.program ~debug:true ~annotate:true p)
|
||||
"llc -O0 -filetype=obj %s -o %s" ".ll";
|
||||
compiles "the annotated x86 listing" (X86.program ~checks:true ~annotate:true p)
|
||||
"as --64 %s -o %s" ".s";
|
||||
compiles "the annotated x86 debug listing"
|
||||
(X86.program ~checks:true ~debug:true ~annotate:true p)
|
||||
"as --64 %s -o %s" ".s";
|
||||
List.iter (fun f -> try Sys.remove f with Sys_error _ -> ()) !files
|
||||
end;
|
||||
|
||||
(* A quoted form is cut short at a character, never inside one: a heading
|
||||
is text, and half a UTF-8 sequence is not. *)
|
||||
Loc.remember ~file:"<snippet-utf8>" (String.concat "" (List.init 60 (fun _ -> "\xc3\xa9")));
|
||||
(match Loc.snippet (Loc.make "<snippet-utf8>" 1 1) with
|
||||
| None -> fail "annotate: no snippet of a remembered line"
|
||||
| Some q ->
|
||||
if not (String.is_valid_utf_8 q) then
|
||||
fail "annotate: a long snippet is cut inside a character: %S" q);
|
||||
|
||||
(* Two packages with a file of the same name, and a function at the same
|
||||
line and column of each: a line table's row names the form of its own
|
||||
file, not whichever util.flan came first. *)
|
||||
if have "llc" && have "objdump" then begin
|
||||
let p = Test_support.checked "programs/twins.flan" in
|
||||
let ir = Emit.program ~debug:true ~annotate:true p in
|
||||
let ll = tmp "twins.ll" and o = tmp "twins.o" in
|
||||
let oc = open_out_bin ll in
|
||||
output_string oc ir;
|
||||
close_out oc;
|
||||
if Sys.command
|
||||
(Printf.sprintf "llc -O0 -filetype=obj %s -o %s > /dev/null 2>&1"
|
||||
(Filename.quote ll) (Filename.quote o)) <> 0
|
||||
then fail "annotate: llc refused the twins"
|
||||
else
|
||||
List.iter
|
||||
(fun (name, mine, other) ->
|
||||
match Dev.asm_of ~ir ~obj:o name with
|
||||
| Error m -> fail "annotate: disassembling %s: %s" name m
|
||||
| Ok (text, _) ->
|
||||
if not (contains_sub text mine) || contains_sub text other then
|
||||
fail "annotate: %s is headed by the other package's file:\n%s"
|
||||
name text)
|
||||
[ ("twin-a/twin", "(* x 3)", "(+ x 7)");
|
||||
("twin-b/twin", "(+ x 7)", "(* x 3)") ];
|
||||
List.iter (fun f -> try Sys.remove f with Sys_error _ -> ()) [ ll; o ]
|
||||
end;
|
||||
|
||||
(* And through the daemon, on the backend it takes unasked: the host's own
|
||||
body, and a body delivered from a buffer that is not on disk. *)
|
||||
if have "objdump" then begin
|
||||
|
||||
Loading…
x
Reference in New Issue
Block a user