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

The IR and the disassembly name the source form each piece of code came from

Browse Source
This commit is contained in:
Joseph Ferano 2026-09-25 11:08:35 +07:00
commit 8b4c6f81df
17 changed files with 979 additions and 99 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

21
TODO.org
View File

@ -1223,15 +1223,18 @@ compilation, the flagship program calls into the agent unconditionally, and
=Reach= cannot prune a package something reachable calls into. A refusal is only
honest when the caller has a way to not ask.
** TODO The IR and the disassembly are not annotated with the source
The emitter writes =.ll= as text and every typed IR node carries a location, so an
IR comment costs nothing and cannot break anything. The disassembly half is
=objdump=, which the daemon already shells out to without =-S= or =-l=. Settled in
conversation: =-O0= gets the full annotation and =-O2= gets nothing or whatever
best-effort mapping falls out, so =--debug= forcing =-O0= is fine. Writing a
disassembler stays off the table; richer annotation of objdump's output needs only
what the daemon already holds, which is where SBCL's advantage actually comes
from.
** DONE The IR and the disassembly are not annotated with the source
CLOSED: [2026-09-25]
Every Flan form heads the code it produced: a comment in the =.ll= (=Emit.annot=),
and in the x86 listing a per-function map from byte offsets to forms, written as
comments after =.size= (=X86.srcmap=). =flan emit= and every dev build annotate;
=--no-annotate= turns it off, and the objects are identical either way (tested).
The daemon's =C-c C-a= places the forms from what it kept of each build: the x86
map, or on LLVM the line table read with =objdump -l= plus the =.ll='s headings,
which exists only under =--debug=; an =-O2= LLVM session says so in =:note=. The
lowering buffer annotates all four sections, the two =llc= ones from a =--debug=
copy of the IR. Rules out writing a disassembler, and reading the source off disk
at disassembly time.
* Runtime

14
bin/main.ml
View File

@ -197,11 +197,12 @@ let x86_flag = "--x86"
mean two different things depending on which subcommand it followed. *)
let llvm_flag = "--llvm"
(* [flan emit --x86] annotates, because it exists to be read. This turns that
off, and the only caller who wants it is the test that assembles the listing
both ways and compares the object's sections byte for byte -- a claim that
comments and the splitting of a [.byte] directive are invisible to the
assembler is worth measuring rather than asserting. *)
(* [flan emit] annotates, with --x86 or without, because it exists to be
read: each Flan form heads the code it produced. This turns that off, and
the callers who want it are the checks that compile the output both ways and
compare the objects byte for byte -- a claim that comments, and the splitting
of a [.byte] directive, are invisible to the assembler and to [llc] is worth
measuring rather than asserting. *)
let no_annotate_flag = "--no-annotate"
(* "This program carries no collector", and the way it is kept is a refusal
@ -676,7 +677,8 @@ let () =
on: the flag is a question asked of what was checked, never a
parameter of what is emitted. *)
if List.mem no_gc_flag args then Flan.Check.no_gc p;
Flan.Emit.program ~checks ~dev ~debug ~pnames ~sanitize p
Flan.Emit.program ~checks ~dev ~debug ~pnames ~sanitize
~annotate:(not (List.mem no_annotate_flag args)) p
|> print_string))
files
| _ :: "build" :: path :: rest ->

13
emacs/MANUAL.md
View File

@ -1059,6 +1059,19 @@ you are reading.
`C-u C-c C-l` asks for the file as well as the name, for the case where the
function you want to read is not in the buffer you are in.
Every section is headed by the Flan forms it came from: each run of
instructions has a comment above it quoting the form that produced it and where
that form is written. The IR carries these comments itself. The two `llc`
sections are compiled from the same IR with a line table added, which changes
no instruction, and their line-table positions are shown as the forms. The x86
section reads the map from byte offsets to forms that the backend writes at the
end of each function. At `-O2` the mapping is only as good as what LLVM keeps.
`C-c C-a` shows source lines the same way, from what the daemon kept of each
build. On the x86 backend, the default, every listing has them. On an LLVM
session they need a line table, which only `flan dev --llvm --debug` has; a
listing without one says so in its `note` line.
The four outputs need `llc`, `as` and `objdump` on `PATH` — the backend writes
machine code rather than mnemonics, so its section is assembled and
disassembled to be readable, which is also a check that the bytes are well

193
emacs/flan-lower.el
View File

@ -177,15 +177,175 @@ reader needs."
"The contents of FILE as a string."
(with-temp-buffer (insert-file-contents file) (buffer-string)))
(defun flan-lower--ll (file flags)
(defun flan-lower--ll (file flags &optional debug)
"The IR for FILE under FLAGS, made once and kept.
Every section is downstream of this one: `llc' reads it twice and the x86
section is the same frontend asked for a different back half."
(let ((ll (expand-file-name "out.ll" (flan-lower--scratch))))
section is the same frontend asked for a different back half.
With DEBUG, the same IR with a line table in it, which is what `llc' is
given: its output then says which source position each instruction came
from, and `flan-lower--annotate-llc' turns those into the forms. A line
table changes no instruction LLVM emits, so the two LLVM sections are still
what the IR section compiles to."
(let ((ll (expand-file-name (if debug "out.dbg.ll" "out.ll")
(flan-lower--scratch))))
(unless (file-exists-p ll)
(apply #'flan-lower--run ll flan-lower-program "emit" file flags))
(apply #'flan-lower--run ll flan-lower-program "emit" file
(if (and debug (not (member "--debug" flags)))
(append flags '("--debug"))
flags)))
ll))
;;; Source lines
;; Every listing here is headed by the Flan forms it came from. The IR carries
;; them itself: `flan emit' writes a `; form file:line:col' comment above the
;; first instruction of each form. The other three lose comments on the way
;; through a compiler, so each gets them back from what survives: `llc' keeps
;; the line table's positions as `.loc' directives, and the x86 backend ends
;; 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)
"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]*; \\([^\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))))
(pcase (flan-lower--split-where where)
(`(,file ,line ,col)
(push (cons file form) (gethash (cons line col) tbl)))))))
tbl))
(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 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[ \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)
(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))
(t (push l out))))
(string-join (nreverse out) "\n")))
(defun flan-lower--srcmap (asm name)
"The x86 backend's source map for NAME out of ASM, as (OFFSET DEPTH WHERE FORM)."
(let ((sym (concat "flan." name)) (out nil))
(dolist (l (split-string asm "\n"))
(let ((f (split-string (string-trim l) "\t")))
(when (and (>= (length f) 6)
(equal (nth 0 f) "#@")
(equal (nth 1 f) sym))
(push (list (string-to-number (substring (nth 2 f) 2) 16)
(string-to-number (nth 3 f))
(nth 4 f)
(string-join (nthcdr 5 f) "\t"))
out))))
(nreverse out)))
(defun flan-lower--annotate-x86 (text srcmap)
"TEXT, objdump's listing of one function, with SRCMAP's forms placed in it.
Each form is written above the first instruction at or past its offset from
the function's first byte, indented by how deeply it is nested."
(let ((base nil) (out nil) (pending srcmap))
(dolist (l (split-string text "\n"))
(cond
((string-match "\\`\\([0-9a-f]+\\) <[^>]+>:" l)
(setq base (string-to-number (match-string 1 l) 16)))
((and base (string-match "\\`[ \t]*\\([0-9a-f]+\\):" l))
(let ((off (- (string-to-number (match-string 1 l) 16) base)))
(while (and pending (<= (car (car pending)) off))
(pcase-let* ((`(,_ ,depth ,where ,form) (pop pending))
(head (format "\t%s# %s" (make-string (* 2 depth) ?\s)
form)))
(push (concat head (make-string (max 1 (- 62 (length head))) ?\s)
(flan-lower--shown where))
out))))))
(push l out))
(string-join (nreverse out) "\n")))
(defun flan-lower--fetch (section file name flags)
"The text of SECTION for NAME in FILE, compiled with FLAGS.
Narrowed to the one function, which is almost always what is wanted: the
@ -198,15 +358,21 @@ prelude is emitted too, so a two-line program is ten thousand lines of IR."
(flan-lower--narrow (flan-lower--slurp (flan-lower--ll file flags))
(concat "^define .*@\"?" sym "\"?(") "^}"))
((or 'O0 'O2)
(let ((s (expand-file-name (format "out.%s.s" section) (flan-lower--scratch))))
(let ((s (expand-file-name (format "out.%s.s" section) (flan-lower--scratch)))
(ll (flan-lower--ll file flags t)))
(unless (file-exists-p s)
(flan-lower--run s flan-lower-llc
(if (eq section 'O0) "-O0" "-O2")
(flan-lower--ll file flags) "-o" s))
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.
(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))
(flan-lower--files asm))))))
('x86
(let ((dis (expand-file-name "out.x86.dis" (flan-lower--scratch))))
(unless (file-exists-p dis)
@ -224,8 +390,13 @@ prelude is emitted too, so a two-line program is ten thousand lines of IR."
;; formed, which reading them never would be.
(flan-lower--run o "as" "--64" "-o" o s)
(flan-lower--run dis "objdump" "-d" "--no-show-raw-insn" o)))
(flan-lower--narrow (flan-lower--slurp dis)
(concat "<" sym ">:") "^$")))
(let ((text (flan-lower--narrow (flan-lower--slurp dis)
(concat "<" sym ">:") "^$"))
(s (expand-file-name "out.x86.s" (flan-lower--scratch))))
(and text
(flan-lower--annotate-x86
text (and (file-exists-p s)
(flan-lower--srcmap (flan-lower--slurp s) name)))))))
(_ (error "no such section: %s" section)))))
(defun flan-lower--narrow (text start end)
@ -542,7 +713,7 @@ that is felt."
;; their intermediates too -- they are not redrawn here, but the next `r'
;; on one of them must not answer out of a file the old IR produced.
(dolist (f (pcase id
('ir '("out.ll" "out.O0.s" "out.O2.s"
('ir '("out.ll" "out.dbg.ll" "out.O0.s" "out.O2.s"
"out.x86.s" "out.x86.o" "out.x86.dis"))
('O0 '("out.O0.s"))
('O2 '("out.O2.s"))

11
emacs/flan.el
View File

@ -2926,7 +2926,16 @@ tail of exactly one packaged name, because a buffer inside a package writes
(when (plist-get r :note)
(flan-disassemble--header "note" (plist-get r :note)))
(insert "\n")
(insert (plist-get r :text))
(let ((start (point)))
(insert (plist-get r :text))
;; The source lines the daemon placed in the listing, and the
;; headings in the IR, are `;' comments; shown as comments so the
;; code between them reads as the code.
(save-excursion
(goto-char start)
(while (re-search-forward "^[ \t]*;.*$" nil t)
(put-text-property (match-beginning 0) (match-end 0)
'face 'font-lock-comment-face))))
(goto-char (point-min))))
(display-buffer flan-disassembly-buffer)))

15
emacs/test-flan.el
View File

@ -1760,7 +1760,10 @@ already rely on it — so nothing here is a stand-in for the real thing."
;; 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))))
(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)) *\t[^\n]*dev-repl\\.flan:[0-9]+:3$"
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"
@ -1965,7 +1968,15 @@ already rely on it — so nothing here is a stand-in for the real thing."
(length (alist-get 'O0 flan-lower--texts))))
(test-flan--check "the x86 section is the backend's bytes, disassembled"
(and (string-match-p "<flan\\.step>:" text)
(string-match-p "push +%rbp" text))))
(string-match-p "push +%rbp" text)))
;; Each section headed by the source, and in the right place: the
;; form is above the code it made, so it is not the section's last
;; line and the IR's is followed by an instruction.
(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))[ \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
;; mtime is the only evidence of that, since a re-emitted out.ll would

8
lib/build.ml
View File

@ -867,12 +867,16 @@ let executable ?(opts = default) ?(csrcs = []) ?(lflags = []) ?(pnames = [])
Filename.concat dir
(Filename.basename out ^ if opts.x86 then ".s" else ".ll")
in
(* A dev build is annotated, because the dev daemon keeps this text beside the
host it built and a disassembly of the host reads its source map out of
it. A comment changes nothing an assembler or [llc] makes of the file. *)
write ll
(if opts.x86 then
X86.program ~checks:opts.checks ~dev:opts.dev ~debug:opts.debug p
X86.program ~checks:opts.checks ~dev:opts.dev ~debug:opts.debug
~annotate:opts.dev p
else
Emit.program ~checks:opts.checks ~dev:opts.dev ~debug:opts.debug ~pnames
~sanitize:opts.sanitize p);
~sanitize:opts.sanitize ~annotate:opts.dev p);
(* [flan_dev.c] is compiled into every build, not only a dev one. Nothing in
a release build calls into it — the compiler only emits a registry lookup
for a name the host was not built with, which cannot arise without cells —

194
lib/dev.ml
View File

@ -3355,10 +3355,19 @@ let rerun t =
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. *)
function, which is most of the difference between readable and not.
The third is source interleaving: the Flan form each run of instructions
came from, above the run. Where the mapping comes from depends on the
backend. The x86 backend knows the exact offset of every byte it writes, so
an annotated build ends each function with a source map in comments, and
the assembly the daemon keeps beside each object is where it is read from
(see [X86.srcmap]). An LLVM build has only what LLVM keeps, which is a line
table and only under [--debug]; the form quoted for a line is read from the
comments in the kept [.ll] (see [Emit.annot]). An optimised LLVM build has
no line table and its instructions are not in source order anyway, so
there the reply says that rather than printing a listing that looks
annotated and is not. *)
let objdump = try Sys.getenv "FLAN_OBJDUMP" with Not_found -> "objdump"
@ -3402,6 +3411,22 @@ let ir_of ~ir name =
bytes when an instruction's encoding does not fit the column. *)
type insn = { off : int; bytes : string; text : string }
(* [objdump -l] puts [path:line] (sometimes followed by a discriminator) on a
line of its own above the first instruction of each run from that line. *)
let line_marker l =
let l = String.trim l in
let l =
match String.index_opt l ' ' with
| Some i -> String.sub l 0 i
| None -> l
in
match String.rindex_opt l ':' with
| Some i when i > 0 && i < String.length l - 1 ->
(match int_of_string_opt (String.sub l (i + 1) (String.length l - i - 1)) with
| Some n when n > 0 -> Some (String.sub l 0 i, n)
| _ -> None)
| _ -> None
let parse_listing ~sym text =
let head = "<" ^ sym ^ ">:" in
let lines = String.split_on_char '\n' text in
@ -3419,9 +3444,14 @@ let parse_listing ~sym text =
let body = upto (drop lines) in
let base = ref None in
let out = ref [] in
let marks = ref [] and pending = ref None in
List.iter
(fun l ->
match String.split_on_char '\t' l with
| [ one ] ->
(match line_marker one with
| Some m -> pending := Some m
| None -> ())
| addr :: bytes :: rest ->
let a = String.trim addr in
let a =
@ -3434,13 +3464,18 @@ let parse_listing ~sym text =
| Some n ->
if !base = None then base := Some n;
let b = match !base with Some b -> b | None -> n in
(match !pending with
| Some (file, line) ->
marks := (n - b, file, line) :: !marks;
pending := None
| None -> ());
out :=
{ off = n - b; bytes = String.trim bytes;
text = String.trim (String.concat "\t" rest) }
:: !out)
| _ -> ())
body;
(List.rev !out, !base <> None)
(List.rev !out, List.rev !marks, !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
@ -3464,7 +3499,79 @@ let target_of ~sym text =
int_of_string_opt (String.sub inner (p + 1) (String.length inner - p - 1))
else None
let render_listing ~sym insns =
(* One source line of a listing, in the listing's comment syntax. *)
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:(shown where) form))
(X86.read_srcmap ~asm (Mangle.sym name))
(* 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.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
(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
(* 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 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 =
let targets =
List.sort_uniq compare
(List.filter_map (fun i -> target_of ~sym i.text) insns)
@ -3477,11 +3584,24 @@ let render_listing ~sym insns =
idx 0 targets
in
let b = Buffer.create 4096 in
(* A source line is written above the first instruction at or past its
offset, after the instruction's label: the label names the address, and
the source says what the code from there on is. *)
let src = ref (List.stable_sort (fun (a, _) (b, _) -> compare a b) src) in
List.iter
(fun i ->
(match label i.off with
| Some lb -> Buffer.add_string b (lb ^ ":\n")
| None -> ());
let rec due () =
match !src with
| (o, l) :: rest when o <= i.off ->
Buffer.add_string b (l ^ "\n");
src := rest;
due ()
| _ -> ()
in
due ();
let text =
match target_of ~sym i.text with
| Some n ->
@ -3513,13 +3633,17 @@ let render_listing ~sym insns =
insns;
Buffer.contents b
let asm_of ~obj name =
(* The listing, and the source lines placed in it: from [source] when it has
any, otherwise from the object's own line table, which only an LLVM
[--debug] build has. Answers the text and whether any source was placed. *)
let asm_of ?(source = []) ?ir ~obj name =
let sym = Mangle.sym name in
let code, text =
run_capture
(String.concat " "
[ Filename.quote objdump; "-d";
"--disassemble=" ^ Filename.quote sym; Filename.quote obj ])
([ Filename.quote objdump; "-d" ]
@ (if ir <> None then [ "-l" ] else [])
@ [ "--disassemble=" ^ Filename.quote sym; Filename.quote obj ]))
in
if code <> 0 then
Error
@ -3527,8 +3651,14 @@ let asm_of ~obj name =
(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)
| _, _, false -> Error (Printf.sprintf "%s found no symbol %s in %s" objdump sym obj)
| insns, marks, true ->
let src =
match source, ir with
| [], Some ir -> llvm_source ~ir marks
| s, _ -> s
in
Ok (render_listing ~src ~sym insns, src <> [])
(* 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. *)
@ -3646,16 +3776,37 @@ let disassemble t ~name ~form =
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 ->
(* The kept source is what the source lines come from: the assembly's
map on x86, the [.ll]'s headings for an LLVM line table. Missing is
not an error — the listing is still the listing. *)
let kept = try Some (read_file o.oll) with Sys_error _ -> None in
let x86 = t.session.Session.x86 in
let source =
match kept with
| Some asm when x86 -> x86_source ~asm name
| _ -> []
in
let ir = if x86 then None else Some (Option.value ~default:"" kept) in
match asm_of ~source ?ir ~obj:o.oso name with
| Ok (text, placed) ->
let note =
if placed then []
else if x86 then
[ ":note "
^ Wire.quote
("no source map for this function in " ^ o.oll
^ ", so the listing has no source lines") ]
else
[ ":note "
^ Wire.quote
"source interleaving needs line tables, which an LLVM \
session has only when started with flan dev --llvm --debug" ]
in
ok
(common
@ [ ":object " ^ Wire.quote o.oso;
":note "
^ Wire.quote
"source interleaving needs line tables this build does not \
emit";
":text " ^ Wire.quote text ])
@ [ ":object " ^ Wire.quote o.oso ]
@ note
@ [ ":text " ^ Wire.quote text ])
| Error m -> error m
(* ── The watch table ───────────────────────────────────────────────── *)
@ -5208,11 +5359,12 @@ let merged_executable ~opts ~csrcs ~lflags ~pnames (p : Tast.program) ~out ~ll =
write ll
(if opts.x86 then
rename_program_main_asm
(X86.program ~checks:opts.checks ~dev:opts.dev ~debug:opts.debug p)
(X86.program ~checks:opts.checks ~dev:opts.dev ~debug:opts.debug
~annotate:opts.dev p)
else
rename_program_main
(Emit.program ~checks:opts.checks ~dev:opts.dev ~debug:opts.debug
~pnames ~sanitize:opts.sanitize p));
~pnames ~sanitize:opts.sanitize ~annotate:opts.dev p));
let cc src name = compile_c ~opts ~tflags ~src ~name () in
let objs =
(cc Runtime_src.source "flan_rt.c"

186
lib/emit.ml
View File

@ -423,6 +423,11 @@ type m = {
attribute asks a pass to produce them. UBSan over this .ll covers the C
and nothing else. *)
sanitize : bool;
(* True when the module is written to be read: every Flan form that emits an
instruction is preceded by a comment quoting it and naming its position.
A comment is nothing to [llc], so the object is the same either way; see
[annot]. *)
ann : bool;
mutable nstr : int;
(* The frame descriptors a dev build's shadow stack points at, counted apart
from [nstr] deliberately. [nstr] is the test [redefinition] uses to decide
@ -968,6 +973,13 @@ type f = {
failure, the handler push and pop, the transfer guards -- none of which
would remember to ask. *)
mutable dloc : string;
(* The source headings waiting for the instruction they are about, oldest
first, each with the serial [annot] handed out for it; and the last one
written, so that a macro's forty forms at one call site are headed once.
See [annot]. *)
mutable aq : (int * string) list;
mutable alast : string;
mutable adepth : int;
}
let fresh f = f.n <- f.n + 1; Printf.sprintf "%%t%d" f.n
@ -975,9 +987,21 @@ let fresh_label f name = f.n <- f.n + 1; Printf.sprintf "%s%d" name f.n
(* Nothing may follow a terminator, so emission after one is dropped: the code
is unreachable and LLVM would reject it. *)
(* An instruction is about to be written, so every heading queued is about it. *)
let ann_due f =
if f.aq <> [] then begin
List.iter (fun (_, l) -> Buffer.add_string f.b l) f.aq;
f.aq <- []
end
let ins f fmt =
Printf.ksprintf
(fun s -> if f.live then Buffer.add_string f.b (" " ^ s ^ f.dloc ^ "\n")) fmt
(fun s ->
if f.live then begin
ann_due f;
Buffer.add_string f.b (" " ^ s ^ f.dloc ^ "\n")
end)
fmt
(* A fixed array has no padding between elements, so its zero value is exactly
a run of zero bytes. Naming that operation lets LLVM choose its bulk-clear
@ -1042,7 +1066,10 @@ let word_of_pattern (v : int32) =
let term f fmt =
Printf.ksprintf
(fun s ->
if f.live then Buffer.add_string f.b (" " ^ s ^ f.dloc ^ "\n");
if f.live then begin
ann_due f;
Buffer.add_string f.b (" " ^ s ^ f.dloc ^ "\n")
end;
f.live <- false)
fmt
@ -1944,6 +1971,110 @@ let fcmp_op = function
| Tast.Le -> "ole" | Tast.Gt -> "ogt" | Tast.Ge -> "oge"
| _ -> assert false
(* ── Source headings ──
In an annotated module every Flan form is headed by a comment quoting it and
naming where it was written, placed above the first instruction it emits, so
the IR reads as the source it came from. Queued rather than written, because
a form that emits nothing must not leave its heading on the next form's
code; the first instruction written flushes the queue, and a form that
finished without one withdraws what it queued.
An atom — a literal, a local, a global — is not headed: it would steal the
heading of the form that uses it. A form the checker invented has line 0 and
no text to quote, and inherits its parent's heading. A form at the position
the last heading named is skipped, which keeps a macro's expansion from
repeating its call site once per form. [X86] heads its listing by the same
rules. *)
let atomic (e : Tast.expr) =
match e.Tast.e with
| Tast.Int _ | Tast.Bool _ | Tast.Float _ | Tast.Str _ | Tast.Unit
| Tast.Zero _ | Tast.None_ | Tast.Uninit _ | Tast.Local _ | Tast.Global _
| Tast.FnAddr _ -> true
| _ -> false
(* 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" 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 (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
let annot f (e : Tast.expr) =
if atomic e || e.Tast.loc.Loc.line = 0 then None
else
match heading e.Tast.loc with
| None -> None
| Some (where, src) ->
let key = where ^ " " ^ src in
if key = f.alast then None
else begin
let prev = f.alast in
f.alast <- key;
incr aserial;
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 ' ' ^ "\t" ^ where ^ "\n") ];
Some (!aserial, prev)
end
(* Every [Tast] node already carries the position it was read from, and until
now nothing wrote them out. The location is set for the duration of a node's
own emission and restored afterwards, so instructions a parent emits *after*
@ -1956,14 +2087,25 @@ let rec value f (e : Tast.expr) : string =
[ins] never wrote. Nothing reads the answer. *)
if not f.live then "poison" else
let v =
match f.dsub with
| None -> value_at f e
| Some _ ->
let saved = f.dloc in
at_loc f e.Tast.loc;
let v = value_at f e in
f.dloc <- saved;
if not f.md.ann then value_located f e
else begin
let d = f.adepth in
let h = annot f e in
f.adepth <- d + 1;
let v = value_located f e in
f.adepth <- d;
(match h with
| Some (s, prev) ->
(* Withdrawn if the form wrote no instruction, a [Unit] in statement
position or a local read: a heading left standing would be read as
belonging to whatever came next. *)
if List.exists (fun (k, _) -> k = s) f.aq then begin
f.aq <- List.filter (fun (k, _) -> k < s) f.aq;
f.alast <- prev
end
| None -> ());
v
end
in
(* An operand held while a sibling may allocate: spilled into a root slot the
instant it exists, the same move a call's result gets in [call_through].
@ -1975,6 +2117,16 @@ let rec value f (e : Tast.expr) : string =
end;
v
and value_located f (e : Tast.expr) : string =
match f.dsub with
| None -> value_at f e
| Some _ ->
let saved = f.dloc in
at_loc f e.Tast.loc;
let v = value_at f e in
f.dloc <- saved;
v
(* The [!DILocation] for a position, memoised: a loop body emits the same few
lines over and over and each would otherwise make its own node. *)
and at_loc f (loc : Loc.t) =
@ -3541,6 +3693,7 @@ let emit_fn m ?(hidden = false) ?(pnames = []) (fn : Tast.fn) =
dsub;
dline = (if fn.Tast.floc.Loc.line = 0 then 1 else fn.Tast.floc.Loc.line);
dloc = "";
aq = []; alast = ""; adepth = 0;
} in
(* Every slot is an alloca in the entry block, because [addr] may take the
address of any of them and mem2reg only promotes entry-block allocas. *)
@ -4519,14 +4672,14 @@ let new_dbg (p : Tast.program) =
d
let new_module ~checks ~dev ~known ?(debug = false) ?(sanitize = false)
(p : Tast.program) =
?(annotate = false) (p : Tast.program) =
let m = {
out = Buffer.create 8192; strs = Buffer.create 512;
structs = Hashtbl.create 16; datas = Hashtbl.create 16;
unions = Hashtbl.create 16;
globals = Hashtbl.create 16;
externs = Hashtbl.create 32;
checks; dev; known; nstr = 0; nfi = 0; sanitize;
checks; dev; known; nstr = 0; nfi = 0; sanitize; ann = annotate;
descs = Hashtbl.create 8;
dbg = (if debug then Some (new_dbg p) else None);
} in
@ -4762,7 +4915,7 @@ let macro_thunk m (fn : Tast.fn) =
copy where there is one, which is what keeps [flan_exit_hook] the merged
build installed in reach of a trap raised inside an expansion. *)
let program ?(checks = true) ?(dev = false) ?(debug = false) ?(pnames = [])
?(sanitize = false) ?(macros = []) ?(hidden = false)
?(sanitize = false) ?(macros = []) ?(hidden = false) ?(annotate = false)
(p : Tast.program) : string =
(* [hidden] and [dev] are opposites and the refusal is here so that they
cannot be written together by accident. A dev build's whole point is that
@ -4774,7 +4927,9 @@ let program ?(checks = true) ?(dev = false) ?(debug = false) ?(pnames = [])
internal
"Emit.program was given ~hidden and ~dev together, and a dev build has \
to export its cells";
let m = new_module ~checks ~dev ~known:(fun _ -> true) ~debug ~sanitize p in
let m =
new_module ~checks ~dev ~known:(fun _ -> true) ~debug ~sanitize ~annotate p
in
(* One cell per function, initialised to the function this build compiled.
Nothing has been redefined yet, so a dev build starts out behaving exactly
like a release one — the indirection is the only difference. *)
@ -4908,7 +5063,8 @@ let program ?(checks = true) ?(dev = false) ?(debug = false) ?(pnames = [])
constants, and omitting them is an undefined [@.str.N] at link time. *)
let redefinition ?(checks = true) ?(dev = false) ?(debug = false)
?(known = fun _ -> true) ?(retains = true)
?call ?(consts = []) (p : Tast.program) ~fns : string =
?call ?(consts = []) ?(annotate = false) (p : Tast.program) ~fns
: string =
let target name =
match List.find_opt (fun (f : Tast.fn) -> f.Tast.name = name) p.Tast.fns with
| Some f -> f
@ -4939,7 +5095,7 @@ let redefinition ?(checks = true) ?(dev = false) ?(debug = false)
let siblings =
List.filter (fun (f : Tast.fn) -> f.Tast.fparent = None) p.Tast.fns
in
let m = new_module ~checks ~dev ~known ~debug p in
let m = new_module ~checks ~dev ~known ~debug ~annotate p in
(* A thunk the module runs itself is excluded from all of this: it is called
directly by [flan_reload_call], so it needs no cell, must not be published
into one, and must not take a registry slot — there are 4096 of those and

37
lib/loc.ml
View File

@ -249,6 +249,35 @@ let lines_of file =
Hashtbl.replace source_cache file v;
v
(** Take [text] as the current contents of [file] from its first non-blank line
on. An editor sends a form padded with newlines so that its positions are
the buffer's own; the padding says nothing about those lines, so what was
known of them is kept, and every line from the form on is the text that was
sent. That is what a snippet quoted while that form is compiled has to
show: the buffer may be unsaved, and the file may not exist at all. *)
let remember ~file text =
let sent = Array.of_list (String.split_on_char '\n' text) in
let first =
let rec go i =
if i >= Array.length sent then None
else if String.trim sent.(i) <> "" then Some i
else go (i + 1)
in
go 0
in
match first with
| None -> ()
| Some first ->
let old = match lines_of file with Some ls -> ls | None -> [||] in
let n = max (Array.length old) (Array.length sent) in
let merged =
Array.init n (fun i ->
if i >= first && i < Array.length sent then sent.(i)
else if i < Array.length old then old.(i)
else "")
in
Hashtbl.replace source_cache file (Some merged)
let source_line (t : t) =
if t.line <= 0 then None
else
@ -334,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

8
lib/session.ml
View File

@ -484,11 +484,11 @@ type change = {
let redefinition (t : t) ?retains ?call ?(consts = []) program ~fns =
if not t.x86 then
Emit.redefinition ~dev:true ~debug:t.debug ~known:(known t) ?retains
~consts ?call program ~fns
~consts ?call ~annotate:true program ~fns
else
match
X86.redefinition ~checks:true ~dev:true ~known:(known t) ?retains ~consts
?call program ~fns
?call ~annotate:true program ~fns
with
| asm -> asm
(* The dev backend covers a subset of the IR and refuses the rest by name,
@ -583,6 +583,9 @@ let restore t h =
let eval ?(origin = "<eval>") ?pause t src : change =
let forms = Reader.read_all ~file:origin src in
(* What an annotated listing quotes for this form is what was sent, not what
the file on disk said when it was last read. *)
Loc.remember ~file:origin src;
Parse.with_imported ~decls:(package_decls t) t.macros @@ fun () ->
(* Through [Load] like any other source, so an evaluated (import ...) means
what it means in a file. Its expansion is what gets spliced, which is also
@ -2115,6 +2118,7 @@ let eval_expr ?(origin = "<eval>") ?(pause = false) t src : change =
| [] -> fail Loc.unknown "nothing to evaluate"
| _ :: f :: _ -> fail f.Form.loc "one expression at a time"
in
Loc.remember ~file:origin src;
(* [Parse.expr] expands, so the imported set has to be in front of it here
exactly as [eval] puts it in front of a declaration: C-x C-e sends one
expression with no import in sight, and the session is the only thing

102
lib/x86.ml
View File

@ -109,7 +109,14 @@ type buf = {
next form's. So [annote] queues, the first byte written afterwards flushes
the queue, and [unannote] withdraws whatever its own form queued and never
spent. *)
mutable ann : (int * string) list;
mutable ann : (int * string * string option) list;
(* The source headings already written, newest first, each with the offset
of the byte it stands above: [(n, entry)], where [entry] is the
tab-separated [depth where form] that [srcmap] writes out. This is the map from machine
code back to source that a disassembly of the object needs and that
nothing in the object carries outside a [--debug] build. [n] is exact for
the same reason every offset here is. *)
mutable spent : (int * string) list;
(* How far to indent a run of bytes, which is the nesting depth of the form
that is emitting it. An argument's bytes step in and the call's step back
out, so the shape of the expression is visible in the left margin without
@ -118,7 +125,7 @@ type buf = {
}
let create () =
{ out = Buffer.create 4096; pend = []; n = 0; ann = []; ind = "" }
{ out = Buffer.create 4096; pend = []; n = 0; ann = []; spent = []; ind = "" }
let flush b =
if b.pend <> [] then begin
@ -142,9 +149,12 @@ let ann_due b =
if b.ann <> [] then begin
flush b;
List.iter
(fun (s, line) ->
(fun (s, line, src) ->
Buffer.add_string b.out line;
Buffer.add_char b.out '\n';
(match src with
| Some e -> b.spent <- (b.n, e) :: b.spent
| None -> ());
if s > !annmax then annmax := s)
b.ann;
b.ann <- []
@ -189,15 +199,15 @@ let set_ind b s = if b.ind <> s then begin flush b; b.ind <- s end
(* Queue one comment line. [pre] is written as given — the callers below spell
their own leading tab and hash — and the serial comes back so that the form
that queued it can withdraw it if it turns out to have emitted nothing. *)
let annote b line =
let annote ?src b line =
incr annser;
b.ann <- b.ann @ [ (!annser, line) ];
b.ann <- b.ann @ [ (!annser, line, src) ];
!annser
(* Drop every heading queued at or after [s] and still unspent. Answers whether
[s] itself was spent, which is the only thing a caller wants to know. *)
let unannote b s =
if b.ann <> [] then b.ann <- List.filter (fun (k, _) -> k < s) b.ann;
if b.ann <> [] then b.ann <- List.filter (fun (k, _, _) -> k < s) b.ann;
!annmax >= s
(* ── Registers ───────────────────────────────────────────────────────── *)
@ -479,7 +489,7 @@ let layout_ctx ~checks ~dev (p : Tast.program) : Emit.m =
p.Tast.globals;
{ Emit.out = Buffer.create 1; strs = Buffer.create 1; structs; datas; unions;
globals; externs = Hashtbl.create 1; checks;
dev; known = (fun _ -> true); dbg = None; sanitize = false;
dev; known = (fun _ -> true); dbg = None; sanitize = false; ann = false;
nstr = 0; nfi = 0; descs = Hashtbl.create 8 }
let sizeof md t = fst (Emit.lay md t)
@ -843,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
@ -888,27 +898,14 @@ let bnote ann b s =
And a form at the same source position as the last heading written is
skipped, which is what keeps a macro from printing its call site once per
form of its expansion. *)
let atomic (e : Tast.expr) =
match e.Tast.e with
| Tast.Int _ | Tast.Bool _ | Tast.Float _ | Tast.Str _ | Tast.Unit
| Tast.Zero _ | Tast.None_ | Tast.Uninit _ | Tast.Local _ | Tast.Global _
| Tast.FnAddr _ -> true
| _ -> false
let atomic = Emit.atomic
let annot f (e : Tast.expr) =
if (not f.ann) || atomic e || e.Tast.loc.Loc.line = 0 then None
else
let loc = e.Tast.loc in
let where = Printf.sprintf "%s:%d:%d" (Filename.basename loc.Loc.file)
loc.Loc.line loc.Loc.col in
match Loc.snippet loc with
match Emit.heading e.Tast.loc with
| None -> None
| Some src ->
let src =
match loc.Loc.macro with
| Some m -> Printf.sprintf "%s [from the macro %s]" src m
| None -> src
in
| Some (where, src) ->
let key = where ^ " " ^ src in
if key = f.alast then None
else begin
@ -916,7 +913,8 @@ let annot f (e : Tast.expr) =
set_ind f.b (String.make (2 * min 12 f.adepth) ' ');
let head = Printf.sprintf "\t%s# %s" f.b.ind src in
let pad = max 1 (62 - String.length head) in
Some (annote f.b (head ^ String.make pad ' ' ^ where))
let src = Printf.sprintf "%d\t%s\t%s" (min 12 f.adepth) where src in
Some (annote ~src f.b (head ^ String.make pad ' ' ^ where))
end
(* Bump-allocate a frame temporary and answer its rbp-relative offset. The
@ -3546,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"))
@ -3693,6 +3694,44 @@ let frame_map (md : Emit.m) (fn : Tast.fn) ~slots ~fixed ~total ~outgoing
Buffer.add_string b (bar ^ "\n");
Buffer.contents b
(* The source map of one function, written after it as comments: one line per
source heading, giving the offset from the function's first byte of the
instruction the heading stands above. The assembler discards all of it, so
the object is the same; what reads it is the dev daemon, which keeps each
module's assembly beside its object and has no line table to ask instead,
and the lowering buffer in the editor. [base] is the prologue's length,
since the body's offsets were counted from the end of it. *)
let srcmap_mark = "#@"
let srcmap out ~sym ~base spent =
if spent <> [] then begin
Buffer.add_string out
(Printf.sprintf
"\t# The source map of %s: offset from its first byte, nesting depth, \
position, form.\n" sym);
List.iter
(fun (n, e) ->
Buffer.add_string out
(Printf.sprintf "\t%s\t%s\t0x%x\t%s\n" srcmap_mark sym (base + n) e))
(List.rev spent)
end
(* The map [srcmap] wrote for [sym], read back out of an assembly file:
[(offset, depth, position, form)] in the order the headings were written,
which is address order. Empty when the file was not annotated. *)
let read_srcmap ~asm sym =
List.filter_map
(fun l ->
match String.split_on_char '\t' (String.trim l) with
| m :: s :: off :: depth :: where :: rest
when m = srcmap_mark && s = sym ->
(match int_of_string_opt off, int_of_string_opt depth with
| Some off, Some depth ->
Some (off, depth, where, String.concat "\t" rest)
| _ -> None)
| _ -> None)
(String.split_on_char '\n' asm)
let emit_fn (md : Emit.m) ~externs ~fns ?(ext = fun _ -> false)
?(slot = fun _ -> None) ?(hidden = false) ?(ann = false) ?dw (fn : Tast.fn)
: string * string =
@ -4223,7 +4262,9 @@ let emit_fn (md : Emit.m) ~externs ~fns ?(ext = fun _ -> false)
| None -> ());
(match dw with Some d -> d.dcur <- None | None -> ());
Buffer.add_string out "\t.cfi_endproc\n";
Buffer.add_string out (Printf.sprintf "\t.size\t%s, . - %s\n\n" sym sym);
Buffer.add_string out (Printf.sprintf "\t.size\t%s, . - %s\n" sym sym);
if ann then srcmap out ~sym:(Mangle.sym fn.Tast.name) ~base:pb.n f.b.spent;
Buffer.add_char out '\n';
Buffer.contents out, Buffer.contents f.rodata
(* Two functions, because the two halves run at different times and have to.
@ -5007,7 +5048,8 @@ let program ~checks ?(dev = false) ?(debug = false) ?(annotate = false)
class-registration thunk a redefined [defclass] carries go through it, and
[flan dev] takes this backend unasked. *)
let redefinition ~checks ?(dev = true) ?(known = fun _ -> true)
?(retains = true) ?(consts = []) ?call (p : Tast.program) ~fns : string =
?(retains = true) ?(consts = []) ?call ?(annotate = false)
(p : Tast.program) ~fns : string =
if not dev then
unsupported
"x86 redefinition without cells: there is nothing to publish a body \
@ -5101,7 +5143,9 @@ let redefinition ~checks ?(dev = true) ?(known = fun _ -> true)
\t.text\n\n";
List.iter
(fun (f : Tast.fn) ->
let t, r = emit_fn md ~externs ~fns:fnstbl ~ext ~slot ~hidden:true f in
let t, r =
emit_fn md ~externs ~fns:fnstbl ~ext ~slot ~hidden:true ~ann:annotate f
in
Buffer.add_string text t;
Buffer.add_string rodata r)
(lifted @ targets);

13
test/programs/annotate.flan Normal file
View File

@ -0,0 +1,13 @@
;;;; A function whose forms nest and loop, for the source annotation of its
;;;; IR, its x86 listing and its disassembly: test_dev.ml reads the forms back
;;;; out of each and checks they come in the order they are written here.
(defn wind [n i32] i32
(let [acc 0]
(dotimes [i n]
(set acc (+ acc (* i 3))))
acc))
(defn main [] i32
(print (wind 10))
0)

2
test/programs/pkgs/twin-a/util.flan Normal file
View 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
View 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
View 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)

249
test/test_dev.ml
View File

@ -3505,6 +3505,255 @@ let () =
end;
List.iter (fun f -> try Sys.remove f with Sys_error _ -> ()) [ dsock; dout ];
(* ── Source annotation ─────────────────────────────────────────── *)
(* The IR, the x86 listing and both disassemblies are headed by the Flan
forms they came from. Each is checked for the forms of one function in
the order they are written, and the objects are checked to be the same
with and without the headings, since the whole licence for writing them
is that nothing but a reader sees them. *)
let in_order text needles =
let rec go from = function
| [] -> true
| n :: rest ->
let ln = String.length n and lt = String.length text in
let rec find i =
if i + ln > lt then None
else if String.sub text i ln = n then Some (i + ln)
else find (i + 1)
in
(match find from with Some i -> go i rest | None -> false)
in
go 0 needles
in
let forms =
[ "(let [acc 0]"; "(dotimes [i n]"; "(set acc (+ acc (* i 3)))";
"(+ acc (* i 3))"; "(* i 3)" ]
in
let p = Test_support.checked "programs/annotate.flan" in
let ll = Emit.program ~annotate:true p and ll0 = Emit.program p in
(match Dev.ir_of ~ir:ll "wind" with
| None -> fail "annotate: no define for wind in the annotated IR"
| Some body ->
if not (in_order body forms) then
fail "annotate: the IR's headings are not the forms in order:\n%s" body;
if not (contains_sub body "annotate.flan:6:3") then
fail "annotate: the IR's heading does not name the position:\n%s" body);
if contains_sub ll0 "annotate.flan:" then
fail "annotate: an IR nobody asked to annotate carries headings";
let asm = X86.program ~checks:true ~annotate:true p
and asm0 = X86.program ~checks:true p in
let map = Dev.x86_source ~asm "wind" in
if not (in_order (String.concat "\n" (List.map snd map)) forms) then
fail "annotate: the x86 source map is not the forms in order: %s"
(String.concat " | " (List.map snd map));
let have prog = Sys.command ("command -v " ^ prog ^ " > /dev/null 2>&1") = 0 in
if not (have "llc" && have "as" && have "objcopy" && have "objdump") then
print_endline "dev: annotation parity skipped (no llc, as, objcopy or objdump)"
else begin
let write path text =
let oc = open_out_bin path in
output_string oc text;
close_out oc
in
let quiet cmd = Sys.command (cmd ^ " > /dev/null 2>&1") = 0 in
let section obj sec =
let bin = obj ^ sec ^ ".bin" in
if quiet
(Printf.sprintf "objcopy -O binary --only-section=%s %s %s" sec
(Filename.quote obj) (Filename.quote bin))
then begin
let text = Build.read_file bin in
(try Sys.remove bin with Sys_error _ -> ());
Some text
end
else None
in
let same what a b =
List.iter
(fun sec ->
if section a sec <> section b sec then
fail "annotate: %s: the %s section differs with the headings" what sec)
[ ".text"; ".data"; ".rodata"; ".data.rel.ro" ]
in
let al = tmp "annot-a.ll" and bl = tmp "annot-b.ll"
and ao = tmp "annot-a.o" and bo = tmp "annot-b.o"
and as_ = tmp "annot-a.s" and bs = tmp "annot-b.s"
and aso = tmp "annot-as.o" and bso = tmp "annot-bs.o"
and dl = tmp "annot-d.ll" and dob = tmp "annot-d.o" in
write al ll; write bl ll0; write as_ asm; write bs asm0;
let llc src obj =
quiet (Printf.sprintf "llc -O0 -filetype=obj -relocation-model=pic %s -o %s"
(Filename.quote src) (Filename.quote obj))
and gas src obj =
quiet (Printf.sprintf "as --64 %s -o %s" (Filename.quote src)
(Filename.quote obj))
in
if not (llc al ao && llc bl bo) then fail "annotate: llc refused the IR"
else same "llc -O0" ao bo;
if not (gas as_ aso && gas bs bso) then fail "annotate: as refused the listing"
else begin
same "the x86 backend" aso bso;
(* The daemon's view of the same object: every offset in the map is an
instruction's, and the forms land in the listing in order. *)
match Dev.asm_of ~source:map ~obj:aso "wind" with
| Error m -> fail "annotate: disassembling the x86 object: %s" m
| Ok (text, placed) ->
if not placed then fail "annotate: no source placed in the x86 listing";
if not (in_order text forms) then
fail "annotate: the x86 disassembly is not headed in order:\n%s" text;
List.iter
(fun (off, _) ->
if not (contains_sub text (Printf.sprintf " %04x " off)) then
fail "annotate: the map's offset %x is no instruction's:\n%s" off text)
map
end;
(* An LLVM build has a line table under --debug, and the form each line
is headed with is read out of the annotated IR. *)
let dir = Emit.program ~debug:true ~annotate:true p in
write dl dir;
if not (llc dl dob) then fail "annotate: llc refused the debug IR"
else begin
match Dev.asm_of ~ir:dir ~obj:dob "wind" with
| Error m -> fail "annotate: disassembling the LLVM object: %s" m
| Ok (text, placed) ->
if not placed then fail "annotate: no line table read from a --debug object";
if not (in_order text
[ "(let [acc 0]"; "(dotimes [i n]"; "(set acc (+ acc (* i 3)))" ])
then fail "annotate: the LLVM disassembly is not headed in order:\n%s" text
end;
List.iter (fun f -> try Sys.remove f with Sys_error _ -> ())
[ 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
let xsock = tmp "annot.sock" and xout = tmp "annot.out" in
(try Sys.remove xsock with Sys_error _ -> ());
let xfd = Unix.openfile xout [ Unix.O_WRONLY; Unix.O_CREAT; Unix.O_TRUNC ] 0o600 in
let xpid =
Unix.create_process flan
[| flan; "dev"; "programs/dev-repl.flan"; "-s"; xsock |]
Unix.stdin xfd Unix.stderr
in
Unix.close xfd;
if not (listening ~pid:xpid xsock) then begin
fail "the annotation daemon %s" !listen_why;
(try Unix.kill xpid Sys.sigkill with Unix.Unix_error _ -> ())
end
else begin
let c = connect xsock in
let text r = Option.value ~default:"" (Wire.string_field r "text") in
let said r = Option.value ~default:"" (Wire.string_field r "message") in
let r = request c "(:op \"disassemble\" :name \"step\" :form \"asm\")" in
if status r <> "ok" then fail "annotate: the host's step: %s" (said r)
else begin
if not (in_order (text r) [ "(set ticks (+ ticks 1))"; "ret" ]) then
fail "annotate: the host's step is not headed by its source:\n%s" (text r);
if Wire.string_field r "note" <> None then
fail "annotate: an annotated listing still carries a note"
end;
let r =
request c
"(:op \"eval\" :code \"\n\n(defn wind [n i32] i32\n (let [acc 0]\n (dotimes [i n]\n (set acc (+ acc (* i 3))))\n acc))\" :file \"/tmp/flan-annotate-unsaved.flan\")"
in
if status r <> "ok" then fail "annotate: delivering wind: %s" (said r)
else begin
let r = request c "(:op \"disassemble\" :name \"wind\" :form \"asm\")" in
if status r <> "ok" then fail "annotate: the delivered wind: %s" (said r)
else if not (in_order (text r) forms) then
fail "annotate: the delivered wind is not headed in order:\n%s" (text r)
else if not (contains_sub (text r) "flan-annotate-unsaved.flan:4:3") then
fail "annotate: the delivered wind's positions are not the buffer's:\n%s"
(text r)
end;
ignore (request c "(:op \"close\")");
Unix.close c;
if not
(await ~ms:5000 (fun () ->
match Unix.waitpid [ Unix.WNOHANG ] xpid with
| 0, _ -> false
| _ -> true
| exception Unix.Unix_error _ -> true))
then begin
(try Unix.kill xpid Sys.sigkill with Unix.Unix_error _ -> ());
(try ignore (Unix.waitpid [] xpid) with Unix.Unix_error _ -> ())
end
end;
List.iter (fun f -> try Sys.remove f with Sys_error _ -> ()) [ xsock; xout ]
end;
(* ── A location that survives an evaluation that did not land ───── *)
(* [Session.eval] replaces the checked program the moment a form checks,