From 40bd96ec65ddd3dcc060e7c7a3f2cdbef003b331 Mon Sep 17 00:00:00 2001 From: Joseph Ferano Date: Fri, 25 Sep 2026 11:08:11 +0700 Subject: [PATCH] A source heading escapes control characters, names its file by the path it was given, and quotes a form cut at a character boundary --- emacs/flan-lower.el | 104 +++++++++++++++++++++++----- emacs/test-flan.el | 4 +- lib/dev.ml | 65 +++++++++++------ lib/emit.ml | 53 ++++++++++++-- lib/loc.ml | 8 ++- lib/x86.ml | 7 +- test/programs/pkgs/twin-a/util.flan | 2 + test/programs/pkgs/twin-b/util.flan | 2 + test/programs/twins.flan | 10 +++ test/test_dev.ml | 70 +++++++++++++++++++ 10 files changed, 278 insertions(+), 47 deletions(-) create mode 100644 test/programs/pkgs/twin-a/util.flan create mode 100644 test/programs/pkgs/twin-b/util.flan create mode 100644 test/programs/twins.flan diff --git a/emacs/flan-lower.el b/emacs/flan-lower.el index 20dbf797..1da34463 100644 --- a/emacs/flan-lower.el +++ b/emacs/flan-lower.el @@ -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) diff --git a/emacs/test-flan.el b/emacs/test-flan.el index ccc712e0..ca9dbe64 100644 --- a/emacs/test-flan.el +++ b/emacs/test-flan.el @@ -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 diff --git a/lib/dev.ml b/lib/dev.ml index 77aa8525..d83191d7 100644 --- a/lib/dev.ml +++ b/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 = diff --git a/lib/emit.ml b/lib/emit.ml index b3f04f33..800e4a71 100644 --- a/lib/emit.ml +++ b/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 diff --git a/lib/loc.ml b/lib/loc.ml index bde82675..9cfb41e4 100644 --- a/lib/loc.ml +++ b/lib/loc.ml @@ -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 diff --git a/lib/x86.ml b/lib/x86.ml index 768a55d4..9d6f15a3 100644 --- a/lib/x86.ml +++ b/lib/x86.ml @@ -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")) diff --git a/test/programs/pkgs/twin-a/util.flan b/test/programs/pkgs/twin-a/util.flan new file mode 100644 index 00000000..6a0c7d36 --- /dev/null +++ b/test/programs/pkgs/twin-a/util.flan @@ -0,0 +1,2 @@ +;;;; One of two packages whose only file is util.flan; see twins.flan. +(defn twin [x i32] i32 (* x 3)) diff --git a/test/programs/pkgs/twin-b/util.flan b/test/programs/pkgs/twin-b/util.flan new file mode 100644 index 00000000..94a1c1df --- /dev/null +++ b/test/programs/pkgs/twin-b/util.flan @@ -0,0 +1,2 @@ +;;;; One of two packages whose only file is util.flan; see twins.flan. +(defn twin [x i32] i32 (+ x 7)) diff --git a/test/programs/twins.flan b/test/programs/twins.flan new file mode 100644 index 00000000..db064a45 --- /dev/null +++ b/test/programs/twins.flan @@ -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) diff --git a/test/test_dev.ml b/test/test_dev.ml index 057fc7c0..169a2eee 100644 --- a/test/test_dev.ml +++ b/test/test_dev.ml @@ -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:"" (String.concat "" (List.init 60 (fun _ -> "\xc3\xa9"))); + (match Loc.snippet (Loc.make "" 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