Joseph Ferano
d9404bb34a
`-dev-` was in every Emacs symbol this client owns and meant nothing to anyone typing one: the daemon is `flan dev` at a shell, but from inside Emacs there is no other kind of connection to distinguish it from. `M-x flan-dev` is now `M-x flan`, `flan-dev-quit` is `flan-quit`, the private prefix `flan-dev--` is `flan--`, and every defcustom follows — ninety-odd symbols, with the two files renamed to emacs/flan.el and emacs/test-flan.el so the file names say the same thing as the symbols in them. No aliases. Renaming a defcustom breaks a config that names it and there is no way around that; the repo has no precedent for softening one, and an alias left behind is what keeps a rename from finishing. MANUAL.md says the old names are gone and how to fix a config, which is the whole of the migration path. Three strings are not symbols and keep their spelling: `.flan-dev.sock`, which bin/main.ml writes and which a renamed variable searching for a renamed file would simply never find; and the two buffer names `*flan-dev*` and ` *flan-dev*`, which name the `flan dev` subcommand's own output rather than anything in elisp. `flan dev` with a space is the CLI and is untouched everywhere. The entry point also stops asking a question it already has the answer to. From a buffer visiting a .flan file it starts that file; from anywhere else it reads one from the minibuffer as before; `C-u` reads one either way, which is how you start a second program without leaving the first. The current buffer is still the only source of the default — the bug where a previous project won over the buffer you were in was fixed by removing `flan--file` from that position, and nothing here puts it back. Four checks on the `interactive' form, evaluated on its own rather than by calling the command, because calling it would build and launch a program and the question is only which file the form arrives at and whether it had to ask. A fifth asserts that nothing answers to the old names. test/test_emacs.ml loads the test file by path and test/test_session.ml names the client file in a comment, so the rename reaches those two lines; nothing else outside emacs/ and the docs moved. Verified by byte-compiling every file clean and by `dune test` and `@page`.
645 lines
29 KiB
EmacsLisp
645 lines
29 KiB
EmacsLisp
;;; flan-lower.el --- Every lowering of one function, in one buffer -*- lexical-binding: t; -*-
|
|
|
|
;; Author: Joseph Ferano <joseph@ferano.io>
|
|
;; Version: 0.1.0
|
|
;; Package-Requires: ((emacs "29.1"))
|
|
;; Keywords: languages, lisp, tools
|
|
|
|
;; The headers above are what make this directory installable. M-x
|
|
;; package-install-file on it reads them, and a file with no Version: is not a
|
|
;; package as far as package.el is concerned -- until now the client was
|
|
;; reachable only by adding it to load-path by hand, which is a thing to
|
|
;; explain to every person who wants to try it.
|
|
;;
|
|
;; 29.1 is the floor because it is the oldest Emacs any of this has been run
|
|
;; against, not because some function here is known to need it. dape, which
|
|
;; flan-dape drives, asks for 29.1 as well and is a soft dependency: it is
|
|
;; reached through declare-function, so the rest of the client loads and works
|
|
;; without it and it is deliberately not listed above. The compiler this talks
|
|
;; to is not an Emacs package and cannot be listed here either -- emacs/MANUAL.md
|
|
;; says what has to be on PATH.
|
|
|
|
;; `spike/x86/dump.sh' prints four lowerings of one function side by side --
|
|
;; the LLVM IR the frontend emits, what `llc' makes of it at -O0 and at -O2,
|
|
;; and what the hand-written x86 backend emits. Reading one against another is
|
|
;; the only way to check a lowering by eye, and the whole reason the second
|
|
;; backend is trustworthy is that the two agree. This is that script with a
|
|
;; buffer around it.
|
|
;;
|
|
;; A scrollback is the wrong shape for it. Three of the four are noise on any
|
|
;; given day and the fourth is the one being worked on, so the four are
|
|
;; sections that fold, and which of them is open is remembered -- keyed to the
|
|
;; section and not to the function, because "I am on the backend this week" is
|
|
;; a fact about the backend and holds across every function looked at while it
|
|
;; is true.
|
|
;;
|
|
;; This is *not* `flan-disassemble', and the two cannot be merged. `C-c C-a'
|
|
;; asks the running program what the body it is calling for a name actually
|
|
;; came out as; only the daemon can answer that, because the daemon compiled
|
|
;; the module and still has both the .ll and the .so. Neither `llc -O2' nor
|
|
;; the hand-written backend has ever been run over that body, so there is no
|
|
;; four-way answer in the daemon to give. This command asks the other
|
|
;; question -- what does the source on disk compile to -- by compiling it, and
|
|
;; its header says so in as many words so that a listing never implies the
|
|
;; stronger claim.
|
|
;;
|
|
;; The folding is `outline-minor-mode', which is Emacs' own and has been since
|
|
;; long before Magit: `outline-flag-region' hides a subtree and
|
|
;; `outline-next-visible-heading' walks between them. Nothing under emacs/
|
|
;; requires a package that is not in Emacs and this does not start.
|
|
;;
|
|
;; Headings are found by the arrow that starts them, `▸' or `▾' at column
|
|
;; zero. That is not decoration standing in for structure: a regexp loose
|
|
;; enough to match four section headers written in ordinary characters also
|
|
;; matches inside three of the four bodies -- LLVM IR has `;' comments,
|
|
;; assembler output has `#' and `;' comments and lines beginning `.', and
|
|
;; objdump prints `<flan.step>:' label lines -- and folding then fragments in
|
|
;; the middle of a listing. Neither arrow can begin a line of any of the
|
|
;; three, so the arrow is both the affordance and the anchor.
|
|
|
|
;;; Code:
|
|
|
|
(require 'subr-x)
|
|
(require 'seq)
|
|
(require 'outline)
|
|
(require 'flan)
|
|
|
|
(defgroup flan-lower nil
|
|
"Every lowering of one Flan function, side by side."
|
|
:group 'flan
|
|
:prefix "flan-lower-")
|
|
|
|
(defcustom flan-lower-buffer "*flan-lowering*"
|
|
"Buffer `flan-lowering' writes into."
|
|
:type 'string)
|
|
|
|
(defcustom flan-lower-program "flan"
|
|
"The Flan compiler this shells out to.
|
|
A buffer under this editor is usually being worked on beside the compiler
|
|
that built it, so the useful value is often an absolute path into a build
|
|
directory rather than whatever is first on PATH."
|
|
:type 'string)
|
|
|
|
(defcustom flan-lower-flags nil
|
|
"Flags passed to `flan emit', and so to both the IR and the x86 section.
|
|
`(\"--dev\")' compares the four dev lowerings rather than the four release
|
|
ones. Only `flan emit' understands them: `llc' is handed the IR that came
|
|
out, so the two LLVM sections follow whatever this chose without being told."
|
|
:type '(repeat string))
|
|
|
|
(defcustom flan-lower-llc "llc"
|
|
"The LLVM static compiler the -O0 and -O2 sections are made with."
|
|
:type 'string)
|
|
|
|
;; The four, in the order they lower: what the frontend wrote, what LLVM makes
|
|
;; of it twice, and what this project's own backend makes of it. The symbols
|
|
;; are what the remembered state is keyed by, so they are the one part of this
|
|
;; list that is not free to change.
|
|
(defconst flan-lower--sections
|
|
'((ir . "LLVM IR")
|
|
(O0 . "LLVM -O0")
|
|
(O2 . "LLVM -O2")
|
|
(x86 . "x86 backend"))
|
|
"Section ids and the names they are shown under, in order.")
|
|
|
|
(defconst flan-lower--heading-re "^[▸▾] "
|
|
"What a section heading looks like from the start of a line.")
|
|
|
|
;; Session state and nothing more. Four booleans do not want a preference
|
|
;; file: it would be a thing to migrate the first time a section is renamed,
|
|
;; and nobody has ever wanted yesterday's fold state back. The IR is open to
|
|
;; begin with because a buffer that opens with everything shut reads as though
|
|
;; the command failed.
|
|
(defvar flan-lower--state
|
|
'((ir . t) (O0 . nil) (O2 . nil) (x86 . nil))
|
|
"Which sections are open, for this Emacs session.
|
|
Keyed by section and not by function on purpose -- see the header. This is
|
|
the single source of truth: a toggle changes this and then applies it to the
|
|
buffer, and a redraw applies it to the buffer it has just drawn. Visibility
|
|
is never read back out, which would tie this to whether outline folds with
|
|
overlays or with text properties.")
|
|
|
|
(defvar flan-lower-fetch-function #'flan-lower--fetch
|
|
"How one section's text is obtained.
|
|
Called with (SECTION FILE NAME FLAGS) and answers a string, or signals an
|
|
error whose message becomes the section's body. A variable rather than a
|
|
call so that the renderer can be driven from a test without four subprocesses
|
|
and an `llc -O2' per redraw.")
|
|
|
|
(defvar-local flan-lower--file nil "Source file the sections were made from.")
|
|
(defvar-local flan-lower--name nil "Flan name the sections were narrowed to.")
|
|
(defvar-local flan-lower--flags nil "Flags `flan emit' was given.")
|
|
(defvar-local flan-lower--texts nil "Alist of section id to its text.")
|
|
(defvar-local flan-lower--dir nil "Scratch directory the intermediates live in.")
|
|
|
|
;;; Faces
|
|
|
|
(defface flan-lower-heading '((t :inherit bold))
|
|
"Face for a section heading.")
|
|
|
|
(defface flan-lower-count '((t :inherit shadow))
|
|
"Face for the line count beside a section heading.")
|
|
|
|
;;; Getting the four
|
|
|
|
(defun flan-lower--scratch ()
|
|
"The scratch directory for this buffer, made on first use.
|
|
The intermediates are kept rather than piped so that refreshing one section
|
|
does not recompile the file: `llc -O2' is the slow one and the IR it reads
|
|
has not changed."
|
|
(unless (and flan-lower--dir (file-directory-p flan-lower--dir))
|
|
(setq flan-lower--dir (make-temp-file "flan-lower-" t)))
|
|
flan-lower--dir)
|
|
|
|
(defun flan-lower--clean ()
|
|
"Remove this buffer's scratch directory."
|
|
(when (and flan-lower--dir (file-directory-p flan-lower--dir))
|
|
(delete-directory flan-lower--dir t))
|
|
(setq flan-lower--dir nil))
|
|
|
|
(defun flan-lower--run (out program &rest args)
|
|
"Run PROGRAM with ARGS, stdout to OUT, and answer OUT.
|
|
A failure is signalled with the program's own stderr, because every one of
|
|
these is a compiler and the compiler's complaint is the whole of what a
|
|
reader needs."
|
|
(let ((err (expand-file-name "stderr" (flan-lower--scratch))))
|
|
(unless (executable-find program)
|
|
(error "no %s on PATH" program))
|
|
(let ((code (apply #'call-process program nil (list (list :file out) err)
|
|
nil args)))
|
|
(unless (eq code 0)
|
|
(error "%s exited %s: %s" program code
|
|
(string-trim
|
|
(with-temp-buffer (insert-file-contents err) (buffer-string)))))
|
|
out)))
|
|
|
|
(defun flan-lower--slurp (file)
|
|
"The contents of FILE as a string."
|
|
(with-temp-buffer (insert-file-contents file) (buffer-string)))
|
|
|
|
(defun flan-lower--ll (file flags)
|
|
"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))))
|
|
(unless (file-exists-p ll)
|
|
(apply #'flan-lower--run ll flan-lower-program "emit" file flags))
|
|
ll))
|
|
|
|
(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
|
|
prelude is emitted too, so a two-line program is ten thousand lines of IR."
|
|
(let ((sym (concat "flan\\." (regexp-quote name))))
|
|
(pcase section
|
|
('ir
|
|
;; LLVM spells the name `@"flan.step"' when it needs quoting and
|
|
;; `@flan.step' when it does not, and a packaged name always needs it.
|
|
(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))))
|
|
(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))
|
|
;; `.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")))
|
|
('x86
|
|
(let ((dis (expand-file-name "out.x86.dis" (flan-lower--scratch))))
|
|
(unless (file-exists-p dis)
|
|
(let ((s (expand-file-name "out.x86.s" (flan-lower--scratch)))
|
|
(o (expand-file-name "out.x86.o" (flan-lower--scratch))))
|
|
;; The IR is asked for first even though this path does not read
|
|
;; it, so that a frontend error is reported once, in whichever
|
|
;; section is fetched first, rather than twice in two dialects.
|
|
(flan-lower--ll file flags)
|
|
(apply #'flan-lower--run s flan-lower-program
|
|
"emit" "--x86" file flags)
|
|
;; The backend writes machine code, not mnemonics, so its .s is
|
|
;; `.byte' blobs. Assembling and disassembling is what makes it
|
|
;; readable -- and it is also a check that the bytes are well
|
|
;; 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 ">:") "^$")))
|
|
(_ (error "no such section: %s" section)))))
|
|
|
|
(defun flan-lower--narrow (text start end)
|
|
"The run of TEXT from the line matching START to the line matching END.
|
|
Both lines are kept, which is what makes a function's closing brace and its
|
|
`.size' part of the listing rather than the start of the next one. Answers
|
|
nil when START never matches, which is what a name the file does not define
|
|
looks like."
|
|
(with-temp-buffer
|
|
(insert text)
|
|
(goto-char (point-min))
|
|
(when (re-search-forward start nil t)
|
|
(let ((beg (line-beginning-position)))
|
|
(forward-line 1)
|
|
(if (re-search-forward end nil t)
|
|
(buffer-substring-no-properties beg (line-beginning-position 2))
|
|
(buffer-substring-no-properties beg (point-max)))))))
|
|
|
|
(defun flan-lower--gather (sections)
|
|
"Fetch each of SECTIONS into `flan-lower--texts', replacing what was there.
|
|
One section's failure is that section's text and not the buffer's: `llc' can
|
|
be missing while the IR is perfectly readable, and a buffer that refuses
|
|
altogether would be the wrong answer to that."
|
|
(dolist (s sections)
|
|
(let ((text (condition-case err
|
|
(or (funcall flan-lower-fetch-function
|
|
s flan-lower--file flan-lower--name
|
|
flan-lower--flags)
|
|
(format "nothing for `%s' here\n" flan-lower--name))
|
|
(error (concat (error-message-string err) "\n")))))
|
|
(setf (alist-get s flan-lower--texts) text))))
|
|
|
|
;;; Drawing it
|
|
|
|
(defun flan-lower--header (label text)
|
|
"Insert a header line naming LABEL with TEXT, wrapped under the label.
|
|
Wrapped by hand rather than with `fill-region', which is what the sibling
|
|
buffer uses: filling canonicalises runs of spaces, and every value here is a
|
|
path or a flag list whose columns are the point of it."
|
|
(let* ((start (point))
|
|
(indent "; ")
|
|
(lead (format "; %-11s " label))
|
|
(col (length lead))
|
|
(fresh t))
|
|
(insert lead)
|
|
(dolist (word (split-string (or text "") "[ \t\n]+" t))
|
|
(cond
|
|
(fresh (setq fresh nil))
|
|
((> (+ col 1 (length word)) 78)
|
|
(insert "\n" indent)
|
|
(setq col (length indent)))
|
|
(t (insert " ") (setq col (1+ col))))
|
|
(insert word)
|
|
(setq col (+ col (length word))))
|
|
(insert "\n")
|
|
(put-text-property start (point) 'face 'font-lock-comment-face)))
|
|
|
|
|
|
;; Enough highlighting to tell the three languages apart at a glance, and no
|
|
;; more. A major mode for each would be three modes to keep, and what is
|
|
;; wanted here is only that a register not read like a mnemonic.
|
|
(defconst flan-lower--ir-keywords
|
|
(regexp-opt '("define" "declare" "ret" "load" "store" "call" "br" "add"
|
|
"sub" "mul" "sdiv" "udiv" "srem" "icmp" "fcmp" "alloca"
|
|
"getelementptr" "phi" "select" "switch" "bitcast" "zext"
|
|
"sext" "trunc" "inttoptr" "ptrtoint" "unreachable" "tail"
|
|
"and" "or" "xor" "shl" "lshr" "ashr" "label")
|
|
'symbols))
|
|
|
|
(defconst flan-lower--ir-types
|
|
(regexp-opt '("i1" "i8" "i16" "i32" "i64" "ptr" "void" "float" "double")
|
|
'symbols))
|
|
|
|
(defun flan-lower--rules (section)
|
|
"Highlighting rules for SECTION, as an alist of regexp to face."
|
|
(pcase section
|
|
('ir `((,flan-lower--ir-keywords . font-lock-keyword-face)
|
|
(,flan-lower--ir-types . font-lock-type-face)
|
|
("[%@][-A-Za-z0-9_.\"$/]+" . font-lock-variable-name-face)
|
|
("^\\s-*;.*$" . font-lock-comment-face)))
|
|
('x86 `(("^ *[0-9a-f]+:" . shadow)
|
|
("<[^>\n]+>" . font-lock-function-name-face)
|
|
("%[a-z0-9]+" . font-lock-variable-name-face)
|
|
("\\$0x[0-9a-f]+" . font-lock-constant-face)
|
|
("#.*$" . font-lock-comment-face)))
|
|
(_ `(("^\\s-*\\.[a-zA-Z_0-9.]+" . font-lock-preprocessor-face)
|
|
("^[^ \t\n#][^ \t\n]*:" . font-lock-function-name-face)
|
|
("%[a-z0-9]+" . font-lock-variable-name-face)
|
|
("\\$-?[0-9]+\\|\\$0x[0-9a-f]+" . font-lock-constant-face)
|
|
("#.*$" . font-lock-comment-face)))))
|
|
|
|
(defun flan-lower--fontify (beg end section)
|
|
"Highlight BEG..END as SECTION's language.
|
|
Earlier rules win, which is why comments come last in every list: a `#' to
|
|
the end of the line is a comment whatever it holds, so it is painted over
|
|
whatever the rules above it found in there."
|
|
(save-excursion
|
|
(dolist (rule (flan-lower--rules section))
|
|
(goto-char beg)
|
|
(while (re-search-forward (car rule) end t)
|
|
(let ((s (match-beginning 0)) (e (match-end 0)))
|
|
;; An anchored rule can match the empty string, and a search that
|
|
;; does not move is a loop that does not end.
|
|
(if (= s e)
|
|
(unless (eobp) (forward-char 1))
|
|
(unless (get-text-property s 'face)
|
|
(put-text-property s e 'face (cdr rule)))))))))
|
|
|
|
(defun flan-lower--insert-section (id label)
|
|
"Insert the heading and body for section ID under LABEL."
|
|
(let* ((raw (or (alist-get id flan-lower--texts) ""))
|
|
;; Trimmed, because the blank line that ends an objdump function is
|
|
;; the narrowing's terminator rather than part of the listing, and a
|
|
;; count that included it would be one instruction out.
|
|
(text (if (string-empty-p (string-trim raw)) raw
|
|
(concat (string-trim-right raw "\n+") "\n")))
|
|
(lines (if (string-empty-p text) 0
|
|
(1- (length (split-string text "\n")))))
|
|
(open (alist-get id flan-lower--state))
|
|
(hbeg (point)))
|
|
(insert (if open "▾ " "▸ "))
|
|
(insert (propertize label 'face 'flan-lower-heading))
|
|
(insert (propertize (format " %d line%s" lines (if (= lines 1) "" "s"))
|
|
'face 'flan-lower-count))
|
|
(insert "\n")
|
|
(put-text-property hbeg (point) 'flan-lower-section id)
|
|
;; The blank line after the listing belongs to the body and not to the
|
|
;; gap between sections. That is what makes an open section breathe and a
|
|
;; buffer with everything shut four adjacent lines -- a summary, which is
|
|
;; the shape it is meant to have when it is closed.
|
|
(let ((bbeg (point)))
|
|
(insert text)
|
|
(unless (string-suffix-p "\n" text) (insert "\n"))
|
|
(flan-lower--fontify bbeg (point) id)
|
|
(insert "\n")
|
|
(put-text-property bbeg (point) 'flan-lower-section id))))
|
|
|
|
(defun flan-lower--draw ()
|
|
"Erase this buffer and write the header and the four sections into it."
|
|
(let ((inhibit-read-only t))
|
|
(erase-buffer)
|
|
(let ((start (point)))
|
|
(insert (format "; every lowering of %s\n" flan-lower--name))
|
|
(put-text-property start (point) 'face 'font-lock-comment-face))
|
|
(flan-lower--header "file" (abbreviate-file-name (or flan-lower--file "")))
|
|
(flan-lower--header "compiler" flan-lower-program)
|
|
(flan-lower--header "flags" (if flan-lower--flags
|
|
(string-join flan-lower--flags " ")
|
|
"none"))
|
|
;; The counterpart of `flan-disassemble's `showing' line, and it has to be
|
|
;; here for the same reason: four listings of a name look exactly like an
|
|
;; answer about the program, and this one is an answer about the file.
|
|
(flan-lower--header
|
|
"showing" "what this file compiles to, not what a running program is \
|
|
calling for this name -- for that, C-c C-a")
|
|
(insert "\n")
|
|
(pcase-dolist (`(,id . ,label) flan-lower--sections)
|
|
(flan-lower--insert-section id label))
|
|
(flan-lower--apply-state)
|
|
(set-buffer-modified-p nil)))
|
|
|
|
;;; Folding
|
|
|
|
(defun flan-lower--heading-bounds ()
|
|
"Bounds of the section whose heading point is on, as (HEAD-END . SUB-END)."
|
|
(let ((hend (line-end-position))
|
|
(send (save-excursion
|
|
(forward-line 1)
|
|
(if (re-search-forward flan-lower--heading-re nil t)
|
|
(1- (match-beginning 0))
|
|
(point-max)))))
|
|
(cons hend (max hend send))))
|
|
|
|
(defun flan-lower--apply-state ()
|
|
"Fold every section the way `flan-lower--state' says, arrows and all."
|
|
(let ((inhibit-read-only t)
|
|
(modified (buffer-modified-p)))
|
|
(save-excursion
|
|
(goto-char (point-min))
|
|
(while (re-search-forward flan-lower--heading-re nil t)
|
|
(goto-char (match-beginning 0))
|
|
(let* ((id (get-text-property (point) 'flan-lower-section))
|
|
(open (alist-get id flan-lower--state))
|
|
(props (text-properties-at (point))))
|
|
;; The arrow is rewritten rather than redrawn with the rest, so the
|
|
;; properties that make it a heading have to be put back by hand:
|
|
;; inserted text inherits nothing the caller did not arrange.
|
|
(delete-char 1)
|
|
(insert (if open "▾" "▸"))
|
|
(set-text-properties (1- (point)) (point) props)
|
|
(goto-char (match-beginning 0))
|
|
(pcase-let ((`(,hend . ,send) (flan-lower--heading-bounds)))
|
|
(outline-flag-region hend send (not open))
|
|
;; Onwards from the end of this heading, so the next search does
|
|
;; not find the arrow that was just rewritten.
|
|
(goto-char hend)))))
|
|
(set-buffer-modified-p modified)))
|
|
|
|
(defun flan-lower--section-at-point ()
|
|
"The section point is in, heading or body, or nil above the first one."
|
|
(get-text-property (point) 'flan-lower-section))
|
|
|
|
(defun flan-lower--goto-section (id)
|
|
"Put point on section ID's heading, if it is here."
|
|
(let ((pos (save-excursion
|
|
(goto-char (point-min))
|
|
(catch 'found
|
|
(while (re-search-forward flan-lower--heading-re nil t)
|
|
(when (eq (get-text-property (match-beginning 0)
|
|
'flan-lower-section)
|
|
id)
|
|
(throw 'found (match-beginning 0))))
|
|
nil))))
|
|
(when pos (goto-char pos))))
|
|
|
|
(defun flan-lower-toggle (&optional event)
|
|
"Open or close the section point is in, or the one EVENT was over.
|
|
Above the first heading there is nothing to fold, so this moves to the first
|
|
section instead of doing nothing -- the same bargain `flan-cnr-tab' makes."
|
|
(interactive (list last-nonmenu-event))
|
|
(when (and event (listp event) (mouse-event-p event)) (mouse-set-point event))
|
|
(let ((id (flan-lower--section-at-point)))
|
|
(if (null id)
|
|
(outline-next-visible-heading 1)
|
|
(setf (alist-get id flan-lower--state) (not (alist-get id flan-lower--state)))
|
|
;; Point may be inside a body that is about to be hidden, and a point
|
|
;; in invisible text is a cursor that appears to have vanished.
|
|
(flan-lower--goto-section id)
|
|
(flan-lower--apply-state))))
|
|
|
|
(defun flan-lower--set-all (open)
|
|
"Open every section if OPEN, else close every one."
|
|
(pcase-dolist (`(,id . ,_) flan-lower--sections)
|
|
(setf (alist-get id flan-lower--state) open))
|
|
(let ((id (flan-lower--section-at-point)))
|
|
(when (and id (not open)) (flan-lower--goto-section id)))
|
|
(flan-lower--apply-state))
|
|
|
|
(defun flan-lower-collapse-all ()
|
|
"Close every section, leaving the four names and their line counts."
|
|
(interactive)
|
|
(flan-lower--set-all nil))
|
|
|
|
(defun flan-lower-expand-all ()
|
|
"Open every section."
|
|
(interactive)
|
|
(flan-lower--set-all t))
|
|
|
|
(defun flan-lower-cycle-all ()
|
|
"Close everything if anything is open, and otherwise open everything."
|
|
(interactive)
|
|
(flan-lower--set-all
|
|
(not (seq-some (lambda (s) (alist-get (car s) flan-lower--state))
|
|
flan-lower--sections))))
|
|
|
|
;;; Refreshing
|
|
|
|
(defun flan-lower--position ()
|
|
"Where point is, as (SECTION . LINE-WITHIN-IT), for putting it back."
|
|
(let ((id (flan-lower--section-at-point)))
|
|
(when id
|
|
(cons id (count-lines
|
|
(or (save-excursion (flan-lower--goto-section id) (point))
|
|
(point-min))
|
|
(line-beginning-position))))))
|
|
|
|
(defun flan-lower--restore (pos screen-line)
|
|
"Put point back at POS and the window back at SCREEN-LINE."
|
|
(if pos
|
|
(when (flan-lower--goto-section (car pos))
|
|
(forward-line (cdr pos)))
|
|
;; Point was in the header, above every section. The top is where it was
|
|
;; and the top is where it goes back to; leaving it wherever the redraw
|
|
;; finished would put it at the end of the buffer, which is a worse jump
|
|
;; than the one this whole function exists to avoid.
|
|
(goto-char (point-min)))
|
|
;; Guarded because under `emacs -batch' there is no window at all, and an
|
|
;; unguarded `set-window-start' would be a failure with nothing to do with
|
|
;; what was being refreshed.
|
|
(when-let ((win (and screen-line (get-buffer-window (current-buffer)))))
|
|
(set-window-start win (save-excursion
|
|
(vertical-motion (- screen-line))
|
|
(point)))))
|
|
|
|
(defun flan-lower--redraw (sections)
|
|
"Re-fetch SECTIONS and draw the buffer again, keeping point where it was."
|
|
(let* ((pos (flan-lower--position))
|
|
(win (get-buffer-window (current-buffer)))
|
|
;; How far down the window point is sitting, so that a redraw is a
|
|
;; redraw and not a jump to the top of a listing being read.
|
|
(screen-line (and win (count-screen-lines (window-start win) (point)))))
|
|
(flan-lower--gather sections)
|
|
(flan-lower--draw)
|
|
(flan-lower--restore pos screen-line)))
|
|
|
|
(defun flan-lower-refresh ()
|
|
"Compile the file again and redraw all four sections."
|
|
(interactive)
|
|
(flan-lower--clean)
|
|
(setq flan-lower--texts nil)
|
|
(flan-lower--redraw (mapcar #'car flan-lower--sections)))
|
|
|
|
(defun flan-lower-refresh-section ()
|
|
"Compile and redraw only the section point is in.
|
|
Worth its own key because the four are not the same price: the IR is the
|
|
frontend alone, and `llc -O2' over a whole program's worth of it is the one
|
|
that is felt."
|
|
(interactive)
|
|
(let ((id (flan-lower--section-at-point)))
|
|
(unless id (user-error "flan: point is not in a section"))
|
|
;; Only this section's intermediate goes; the IR everything is downstream
|
|
;; of stays, which is the whole saving.
|
|
;; The IR is what the other three are made from, so refreshing it drops
|
|
;; 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"
|
|
"out.x86.s" "out.x86.o" "out.x86.dis"))
|
|
('O0 '("out.O0.s"))
|
|
('O2 '("out.O2.s"))
|
|
('x86 '("out.x86.s" "out.x86.o" "out.x86.dis"))))
|
|
(let ((p (expand-file-name f (flan-lower--scratch))))
|
|
(when (file-exists-p p) (delete-file p))))
|
|
(flan-lower--redraw (list id))))
|
|
|
|
;;; The mode
|
|
|
|
(defvar flan-lower-mode-map
|
|
(let ((map (make-sparse-keymap)))
|
|
(define-key map (kbd "TAB") #'flan-lower-toggle)
|
|
(define-key map (kbd "RET") #'flan-lower-toggle)
|
|
(define-key map [mouse-1] #'flan-lower-toggle)
|
|
(define-key map [backtab] #'flan-lower-cycle-all)
|
|
(define-key map "c" #'flan-lower-collapse-all)
|
|
(define-key map "e" #'flan-lower-expand-all)
|
|
;; `n' and `p' move between the buffer's own units, the way they do in
|
|
;; `flan-inspect-mode' and `flan-cnr-mode'. Here the unit is a section.
|
|
(define-key map "n" #'outline-next-visible-heading)
|
|
(define-key map "p" #'outline-previous-visible-heading)
|
|
(define-key map "g" #'flan-lower-refresh)
|
|
(define-key map "r" #'flan-lower-refresh-section)
|
|
(define-key map "q" #'quit-window)
|
|
map)
|
|
"Keys in `flan-lower-mode'.")
|
|
|
|
(define-derived-mode flan-lower-mode special-mode "flan-lower"
|
|
"Every lowering of one Flan function, in foldable sections.
|
|
|
|
\\{flan-lower-mode-map}"
|
|
(setq buffer-read-only t)
|
|
(setq-local truncate-lines t)
|
|
;; Set before the minor mode goes on, because that is when it reads them.
|
|
(setq-local outline-regexp "[▸▾] ")
|
|
(setq-local outline-level (lambda () 1))
|
|
(outline-minor-mode 1)
|
|
;; Minor-mode bindings take precedence over this mode's map. Outline owns
|
|
;; TAB by default, so give this buffer its intended folding keys back
|
|
;; without changing Outline's bindings anywhere else.
|
|
(let ((map (copy-keymap outline-minor-mode-map)))
|
|
(define-key map (kbd "TAB") #'flan-lower-toggle)
|
|
(define-key map [backtab] #'flan-lower-cycle-all)
|
|
(setq-local minor-mode-overriding-map-alist
|
|
(cons (cons 'outline-minor-mode map)
|
|
(assq-delete-all 'outline-minor-mode
|
|
minor-mode-overriding-map-alist))))
|
|
(add-hook 'kill-buffer-hook #'flan-lower--clean nil t))
|
|
|
|
;;;###autoload
|
|
(defun flan-lowering (name &optional file)
|
|
"Show every lowering of NAME in FILE: the IR, -O0, -O2, and the x86 backend.
|
|
|
|
FILE defaults to the file the current buffer is visiting. NAME is the Flan
|
|
one -- `step', not `flan.step' -- and a packaged function is written the way
|
|
the program names it, `sim/settle'.
|
|
|
|
What this shows is what FILE compiles to today, which is not the same claim
|
|
as `flan-disassemble' (\\[flan-disassemble]): that one asks the running program what the body
|
|
it is calling for a name actually came out as, and only the daemon can
|
|
answer it. The two cannot be merged, because the daemon has the installed
|
|
body's IR and its object and has never run either `llc -O2' or the x86
|
|
backend over it.
|
|
|
|
Which sections are open is remembered for the session, by section rather
|
|
than by function: asking for a different name leaves whichever of the four
|
|
was being read open."
|
|
(interactive
|
|
(list (or (thing-at-point 'symbol t)
|
|
(completing-read
|
|
"Lowerings of: "
|
|
(mapcar #'car (seq-filter (lambda (d) (equal (nth 1 d) "fn"))
|
|
flan--defs))
|
|
nil nil nil nil
|
|
(and (fboundp 'flan-current-defun-name)
|
|
(flan-current-defun-name))))
|
|
(when current-prefix-arg
|
|
(read-file-name "Lowerings from file: " nil nil t))))
|
|
(let ((src (or file buffer-file-name)))
|
|
(unless src
|
|
(user-error "flan: no file to compile; visit one or give it a file"))
|
|
(with-current-buffer (get-buffer-create flan-lower-buffer)
|
|
(unless (derived-mode-p 'flan-lower-mode) (flan-lower-mode))
|
|
;; A new name means new intermediates only if the file changed; the
|
|
;; narrowing is done here, so the same file's IR is reused across names.
|
|
(unless (equal flan-lower--file (expand-file-name src))
|
|
(flan-lower--clean))
|
|
(setq flan-lower--file (expand-file-name src)
|
|
flan-lower--name name
|
|
flan-lower--flags flan-lower-flags
|
|
flan-lower--texts nil)
|
|
(flan-lower--gather (mapcar #'car flan-lower--sections))
|
|
(flan-lower--draw)
|
|
(goto-char (point-min)))
|
|
(display-buffer flan-lower-buffer)))
|
|
|
|
(provide 'flan-lower)
|
|
;;; flan-lower.el ends here
|