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

Merge branch 'dwarf-debug' into dev-loop

Browse Source 
# Conflicts:
#	test/test_acceptance.ml
This commit is contained in:
Joseph Ferano 2026-09-12 04:03:06 +07:00
commit 71bc492cad
8 changed files with 1411 additions and 21 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

44
bin/main.ml
View File

@ -38,6 +38,25 @@ let load path : Flan.Load.t =
let checked path = Flan.Check.program (load path).decls
(* What the source called each parameter, per function. The typed IR refers to
locals by slot index and records no names — [Check] has them in its scope
list and drops them — so the debug info would otherwise print [p0] for
every argument. Slots 0..n-1 are the parameters in order ([Tast.fn]), which
is what makes this recoverable here, from declarations that are already in
hand, rather than needing a change to the typed IR. It stops at the
parameters: a let-bound local's name is genuinely not available without one.
Only gathered for a debug build. *)
let param_names (l : Flan.Load.t) =
List.filter_map
(fun (d : Flan.Ast.decl) ->
match d.Flan.Ast.d with
| Flan.Ast.Defn fn ->
Some (fn.Flan.Ast.name,
List.map (fun (p : Flan.Ast.field) -> p.Flan.Ast.fname)
fn.Flan.Ast.params)
| _ -> None)
l.Flan.Load.decls
(* Bounds checks are on unless a build asks for them off — the release
decision, not the optimisation level (NEXT.md, Bounds checks). *)
let no_checks_flag = "--no-bounds-checks"
@ -47,7 +66,13 @@ let no_checks_flag = "--no-bounds-checks"
so a loaded module can reach them (NEXT.md, the dev loop). *)
let dev_flag = "--dev"
let flags = [ no_checks_flag; dev_flag ]
(* Source-level debugging: DWARF in the IR, -g on the C, and -O0 forced.
Its own flag and not a mode of --dev, because the two answer different
questions — --dev is "can I redefine this while it runs", --debug is "can I
stop it and read it". See [Build.opts]. *)
let debug_flag = "--debug"
let flags = [ no_checks_flag; dev_flag; debug_flag ]
(* [--target=wasm32-wasi], the one cross target. Unlike the flags above it
carries a value, so it is matched by prefix and stripped from the residual
@ -127,15 +152,21 @@ let () =
| _ :: "emit" :: args when List.exists (fun a -> not (is_flag a)) args ->
let checks = not (List.mem no_checks_flag args) in
let dev = List.mem dev_flag args in
let debug = List.mem debug_flag args in
let files = List.filter (fun a -> not (is_flag a)) args in
List.iter
(fun path ->
with_errors path (fun () ->
checked path |> Flan.Emit.program ~checks ~dev |> print_string))
let l = load path in
let pnames = if debug then param_names l else [] in
Flan.Check.program l.decls
|> Flan.Emit.program ~checks ~dev ~debug ~pnames
|> print_string))
files
| _ :: "build" :: path :: rest ->
let checks = not (List.mem no_checks_flag rest) in
let dev = List.mem dev_flag rest in
let debug = List.mem debug_flag rest in
let target = target_of rest in
let out =
match List.filter (fun a -> not (is_flag a)) rest with
@ -150,7 +181,7 @@ let () =
| _ ->
prerr_endline
"usage: flan build <file.flan> [-o out] [--no-bounds-checks] \
[--dev] [--target=wasm32-wasi]";
[--dev] [--debug] [--target=wasm32-wasi]";
exit 2
in
with_errors path (fun () ->
@ -162,8 +193,9 @@ let () =
raylib and still be buildable for wasm32. *)
let p, csrcs, lflags = Flan.Reach.link ~dev l p in
ignore (Flan.Build.executable
~opts:{ Flan.Build.default with checks; dev; target }
~csrcs ~lflags p ~out))
~opts:{ Flan.Build.default with checks; dev; debug; target }
~csrcs ~lflags ~pnames:(if debug then param_names l else [])
p ~out))
(* The daemon an editor talks to: one session, the program it belongs to
running beside it, and a socket. Unlike [flan reload] the session persists,
so a defvar added by one evaluation is part of what the next one is checked
@ -228,7 +260,7 @@ let () =
prerr_endline
"usage: flan (read|parse|check|emit|shim) <file.flan>...\n\
\ flan build <file.flan> [-o out] [--no-bounds-checks] [--dev] \
[--target=wasm32-wasi]\n\
[--debug] [--target=wasm32-wasi]\n\
\ flan run <file.flan> [args...]\n\
\ flan reload <program.flan> <forms.flan> [-o out.so]\n\
\ flan dev <program.flan> [-s socket]";

229
emacs/flan-dape.el Normal file
View File

@ -0,0 +1,229 @@
;;; flan-dape.el --- Debug a Flan program with dape and lldb-dap -*- lexical-binding: t; -*-
;; The other half of the dev loop. flan-dev.el is about a program that keeps
;; running while you change it; this is about stopping one and reading it.
;;
;; There is no DAP implementation here and there should not be. `flan build
;; --debug' writes DWARF into the executable, lldb reads it, and `lldb-dap'
;; speaks DAP on lldb's behalf — so what is left for Emacs is a `dape-configs'
;; entry that knows how to build a .flan file and where the binary lands.
;;
;; It works at all because of the layout. A Flan struct is its C struct, a
;; slot is an ordinary alloca and there are no tag words or object headers
;; anywhere (plan.org, Memory), so lldb's own C support prints a Flan value
;; correctly with nothing taught to it. The compile unit says DW_LANG_C99 for
;; that reason.
;;
;; M-x flan-debug builds the file the current buffer is visiting and stops it
;; at `main'. Breakpoints are ordinary dape breakpoints in the .flan buffer —
;; `dape-breakpoint-toggle' on a line — because the DWARF line table names the
;; .flan file, not the generated .ll. `dape-breakpoint-global' works too, and
;; is the way to break on a function without hunting for its first line.
;;
;; Two things are worth knowing before they surprise you; both have their own
;; heading at the bottom of this file, written from lldb transcripts rather
;; than from reasoning about what ought to happen:
;;
;; - a --dev build and a --debug build are different builds, and M-x
;; flan-debug does not attach to the program `flan dev' is running;
;; - across a redefinition a breakpoint set by NAME gains a second location
;; and both stay live, while one set by FILE AND LINE stops firing —
;; because the redefinition module carries no DWARF yet.
;;; Code:
(require 'subr-x)
(declare-function dape "dape" (config &optional skip-compile))
(declare-function dape--config-eval "dape" (key options &optional skip-functions))
(declare-function dape-breakpoint-toggle "dape" ())
(defvar dape-configs)
(defgroup flan-dape nil
"Debugging a Flan program under lldb."
:group 'flan
:prefix "flan-dape-")
(defcustom flan-dape-command "flan"
"The flan executable used to build a program for debugging.
Its own option rather than flan-dev.el's `flan-dev-command', because this
file is meant to load without that one: editing Flan, debugging Flan and
attaching to a running Flan are three independent things to want."
:type 'string)
(defcustom flan-dape-adapter "lldb-dap"
"The DAP adapter binary.
Fedora and Debian ship it as lldb-dap; older LLVM called it lldb-vscode."
:type 'string)
(defcustom flan-dape-stop-at-entry t
"Whether to stop at the program's entry before running.
On by default: a debug session that starts by running to completion has
told you nothing, and the first thing anyone does is set a breakpoint."
:type 'boolean)
(defcustom flan-dape-extra-flags '()
"Extra flags passed to `flan build' alongside --debug.
--dev belongs here if you want the cells as well as the line tables; see
\"Reloading and breakpoints\" at the bottom of flan-dape.el for what that
does and does not buy."
:type '(repeat string))
(defun flan-dape--source ()
"The .flan file this session is about.
The buffer's own file, or the nearest one up from it — so M-x flan-debug
from a *compilation* buffer or a dired still has an answer."
(or (and buffer-file-name
(string-suffix-p ".flan" buffer-file-name)
buffer-file-name)
(car (directory-files default-directory t "\\.flan\\'"))
(user-error "No .flan file here to debug")))
(defun flan-dape--binary (source)
"Where the debug build of SOURCE goes.
Not beside the source. A debug build is -O0 with DWARF in it and is not
the artefact anyone means by the program's name, so it must not overwrite
one made by `flan build'."
(expand-file-name
(concat "flan-dbg-" (file-name-base source))
temporary-file-directory))
(defun flan-dape--compile-command (source)
"The shell command that builds SOURCE for debugging."
(mapconcat #'shell-quote-argument
(append (list flan-dape-command "build" source "--debug")
flan-dape-extra-flags
(list "-o" (flan-dape--binary source)))
" "))
;; The entry itself. `compile' is dape's own pre-launch hook, so the build
;; happens through `compile-command' and its errors land in a compilation
;; buffer that `next-error' walks — which is the whole reason not to shell out
;; from here. Flan's diagnostics are file:line:col, so they are already in a
;; shape compilation-mode understands.
;;
;; The unquoted forms are evaluated by `dape--config-eval' when a session
;; starts, in the buffer it started from — which is why `flan-dape--source'
;; can just read `buffer-file-name'. `dape' itself expects an already
;; evaluated config, so `flan-debug' below must not hand it the raw entry.
(defconst flan-dape-config
'(modes (flan-mode)
ensure dape-ensure-command
command-cwd dape-command-cwd
compile (flan-dape--compile-command (flan-dape--source))
:type "lldb-dap"
:request "launch"
:cwd "."
:program (flan-dape--binary (flan-dape--source))
:args []
:stopOnEntry flan-dape-stop-at-entry)
"The `dape-configs' entry for a Flan program, without the adapter command.
Separate from the registration below so a user who wants a variant — a
different adapter, extra launch arguments — can start from this rather
than retype it.")
;;;###autoload
(defun flan-dape-register ()
"Add the `flan' entry to `dape-configs'.
Idempotent, so reloading this file does not stack duplicates."
(when (boundp 'dape-configs)
(setq dape-configs
(cons (cons 'flan (append (list 'command flan-dape-adapter)
(copy-sequence flan-dape-config)))
(assq-delete-all 'flan dape-configs)))))
;;;###autoload
(defun flan-debug ()
"Build the Flan file at point with debug info and start dape on it.
Equivalent to \\[dape] with the `flan' configuration, and exists so the
common case is one command rather than a config prompt."
(interactive)
(require 'dape)
(flan-dape-register)
;; Through `dape--config-eval', not `alist-get': `dape' takes a config whose
;; forms have already been evaluated — that is what \[dape] does after
;; reading one — and handing it the stored entry would pass the *list*
;; (flan-dape--binary (flan-dape--source)) to lldb as a program name.
(dape (dape--config-eval 'flan nil)))
;; Registered on load and again after dape loads, because either order
;; happens: a user may load this from their init before dape exists.
(with-eval-after-load 'dape (flan-dape-register))
(flan-dape-register)
;; The binding goes in here rather than in flan-mode.el so that this file is
;; the only thing that has to be loaded to get it, and flan-mode keeps working
;; for anyone who never installs dape. C-c C-g, for "go": every other letter
;; that suggests debugging is taken — C-c C-d is `flan-describe', C-c C-b is
;; `flan-break', which is the condition system's break loop and a different
;; thing entirely.
;;;###autoload
(with-eval-after-load 'flan-mode
(define-key (symbol-value 'flan-mode-map) (kbd "C-c C-g") #'flan-debug))
;;; --dev and --debug are different builds
;;
;; `flan dev' — what flan-dev.el connects to — builds with --dev: every
;; cross-function call goes through a cell so a redefinition can be installed,
;; and -rdynamic exports those cells. `flan build --debug' is a different
;; axis: -O0, DWARF, and no cells unless --dev is also passed.
;;
;; They compose, and `flan-dape-extra-flags' is where to say so, but they do
;; not share a process. M-x flan-debug launches its own program under lldb;
;; it does not attach to the one `flan dev' is running. Attaching to that one
;; would want lldb-dap's attach request and a pid, which is a further thing and
;; is not implemented here — said plainly rather than half-offered.
;;
;; What --dev costs the debugger is less than it sounds. A call site becomes a
;; load from a mutable global and an indirect call through the result, so the
;; callee is found at run time rather than bound at link time. Stack walking
;; is unaffected: the frame is laid out the same way and lldb reads it the
;; same way, so a backtrace through a cell still names the Flan caller and its
;; line. Stepping *into* a call is where it shows — `step' lands in whatever
;; the cell currently holds, which is the honest answer and occasionally not
;; the one on the screen, if the body was redefined since.
;;
;;; Reloading and breakpoints
;;
;; The first confusing thing anyone will hit, so it is written down rather
;; than discovered. What follows was measured with lldb against a --dev
;; --debug build of test/programs/reload.flan and a redefinition module built
;; by `flan reload'; none of it is inference.
;;
;; Each redefinition is a fresh .so that the program dlopens, and the cell is
;; then pointed at the new body. Nothing is ever dlclosed, so the old body is
;; still mapped, and every call site that has not gone through the cell again
;; still reaches it. There are therefore two live bodies, and what a
;; breakpoint does depends on how it was set.
;;
;; A breakpoint set by NAME follows the reload by itself. lldb re-resolves
;; name breakpoints against each module as it loads, so on the dlopen it prints
;; "1 location added to breakpoint 1" and then has two:
;;
;; 1: name = 'flan.bump', locations = 2, resolved = 2, hit count = 2
;; 1.1: where = host`flan.bump + 12 at reload.flan:34:3, ... hit count = 1
;; 1.2: where = v2.so`flan.bump, address = 0x00007ffff7fba1a0, ... hit count = 1
;;
;; Both fire, and both are correct — 1.1 is not stale, it is the body the old
;; call sites still run. That is `dape-breakpoint-global', which sets by name.
;;
;; A breakpoint set by FILE AND LINE does not follow, and the reason is not
;; that dape pinned it to an address. It stays at locations = 1 because the
;; redefinition module carries no line table for it to resolve against. Given
;; one it does follow: a pending breakpoint on a file the executable had never
;; heard of went from "no locations (pending)" to "1 location added" the moment
;; a .so with DWARF for that file was dlopened, and stopped with full source.
;; So the gap is exactly one missing thing, and nothing about dlopen.
;;
;; That missing thing, by name: `Emit.redefinition' takes a ~debug argument and
;; `Session.eval' does not pass it, so `flan reload' and the `flan dev' daemon
;; build modules without DWARF. Until they do, a reloaded body breaks by name
;; and shows disassembly instead of source, and a line breakpoint in the .flan
;; buffer silently stops firing after the first C-c C-c. lib/session.ml is the
;; dev loop's file and is not this one's to change.
;;
;; So, for now: debug with `dape-breakpoint-global' if you are also reloading,
;; and use line breakpoints for a program you are only running.
(provide 'flan-dape)
;;; flan-dape.el ends here

138
emacs/test-flan-dape.el Normal file
View File

@ -0,0 +1,138 @@
;;; test-flan-dape.el --- Drive a real dape session at a Flan program -*- lexical-binding: t; -*-
;; Run from the repository root, with flan on PATH and dape on the load path:
;;
;; emacs -Q --batch -L emacs -L /path/to/dape -l emacs/test-flan-dape.el
;;
;; Not part of `dune test'. It needs Emacs, dape, lldb-dap and a built flan
;; all at once, and wiring four optional things into the acceptance table
;; would make the table's failures mean less rather than more — the DWARF
;; itself is tested there, against LLVM and against lldb directly. What this
;; adds is the last link: that dape, driving lldb-dap, sets a breakpoint from
;; a .flan buffer, hits it, and reports Flan frames and locals.
;;
;; It exits non-zero and says why if any of that does not happen.
;;; Code:
(require 'flan-mode)
(require 'dape)
(require 'flan-dape)
(defvar flan-dape-test--program "test/programs/debug.flan")
(defvar flan-dape-test--failures 0)
(defun flan-dape-test--fail (fmt &rest args)
(setq flan-dape-test--failures (1+ flan-dape-test--failures))
(message "FAIL %s" (apply #'format fmt args)))
(defun flan-dape-test--ok (what)
(message " ok %s" what))
;; Batch Emacs has no idle loop, so every wait is an explicit pump.
(defun flan-dape-test--pump (pred secs)
(let ((deadline (+ (float-time) secs)))
(while (and (< (float-time) deadline) (not (funcall pred)))
(accept-process-output nil 0.05))
(funcall pred)))
(defun flan-dape-test--stopped ()
(dape--live-connection 'stopped t))
(unless (executable-find flan-dape-command)
(message "test-flan-dape: skipped (no %s on PATH)" flan-dape-command)
(kill-emacs 0))
(unless (executable-find flan-dape-adapter)
(message "test-flan-dape: skipped (no %s on PATH)" flan-dape-adapter)
(kill-emacs 0))
(setq dape-cwd-function (lambda () default-directory))
;; The breakpoint is set in the .flan buffer, by line, before anything is
;; built — which is the only way a person would ever set one, and the thing
;; that cannot work without a line table naming the .flan file.
(with-current-buffer (find-file-noselect flan-dape-test--program)
(unless (eq major-mode 'flan-mode)
(flan-dape-test--fail "%s did not open in flan-mode" flan-dape-test--program))
(unless (eq (key-binding (kbd "C-c C-g")) 'flan-debug)
(flan-dape-test--fail "C-c C-g is not bound to flan-debug in a Flan buffer"))
(goto-char (point-min))
(search-forward "(set (.heat c)")
(dape-breakpoint-toggle)
(let ((config (dape--config-eval 'flan nil)))
;; `dape--config-eval' is where the unquoted forms in `flan-dape-config'
;; turn into strings. If this is a list rather than a path, `flan-debug'
;; handed dape an unevaluated config and lldb would be given a program
;; named "(flan-dape--binary ...)".
(unless (stringp (plist-get config :program))
(flan-dape-test--fail ":program did not evaluate to a path: %S"
(plist-get config :program)))
(unless (zerop (call-process-shell-command (plist-get config 'compile) nil nil))
(flan-dape-test--fail "the configured build failed: %s"
(plist-get config 'compile))
(kill-emacs 1))
(flan-dape-test--ok "the config builds the program it points lldb at")
(dape config 'skip-compile)))
(if (not (flan-dape-test--pump #'flan-dape-test--stopped 60))
(flan-dape-test--fail "the session never stopped at the entry point")
(flan-dape-test--ok "lldb-dap launched and stopped at entry")
(dape-continue (flan-dape-test--stopped))
;; The entry stop has to clear before the next one counts as the breakpoint.
(flan-dape-test--pump (lambda () (not (flan-dape-test--stopped))) 5)
(if (not (flan-dape-test--pump #'flan-dape-test--stopped 60))
(flan-dape-test--fail "the breakpoint in %s never hit" flan-dape-test--program)
(let* ((conn (flan-dape-test--stopped))
(thread (car (dape--threads conn)))
(frames (plist-get thread :stackFrames))
(top (car frames)))
(flan-dape-test--ok "the breakpoint hit")
(unless (equal (plist-get top :name) "flan.tick")
(flan-dape-test--fail "the top frame is %S, wanted flan.tick"
(plist-get top :name)))
(unless (equal (plist-get (plist-get top :source) :name) "debug.flan")
(flan-dape-test--fail "the top frame's source is %S, wanted debug.flan"
(plist-get (plist-get top :source) :name)))
(unless (integerp (plist-get top :line))
(flan-dape-test--fail "the top frame has no line number"))
(flan-dape-test--ok
(format "frame %s at %s:%s" (plist-get top :name)
(plist-get (plist-get top :source) :name) (plist-get top :line)))
;; Locals, which dape fetches lazily — so they are asked for here.
(let ((seen nil) (done nil))
(dape-request
conn :scopes (list :frameId (plist-get top :id))
(lambda (body _err)
(dolist (scope (append (plist-get body :scopes) nil))
(dape-request
conn :variables
(list :variablesReference (plist-get scope :variablesReference))
(lambda (body _err)
(dolist (v (append (plist-get body :variables) nil))
(push (list (plist-get v :type) (plist-get v :name)
(plist-get v :value))
seen)))))
(setq done t)))
(flan-dape-test--pump (lambda () done) 15)
(accept-process-output nil 1.0)
(dolist (want '(("int" "n" "41") ("Cell *" "c" nil)))
(let ((hit (seq-find (lambda (v)
(and (equal (nth 0 v) (nth 0 want))
(equal (nth 1 v) (nth 1 want))
(or (null (nth 2 want))
(equal (nth 2 v) (nth 2 want)))))
seen)))
(if hit
(flan-dape-test--ok (format "%s %s = %s" (nth 0 hit) (nth 1 hit)
(nth 2 hit)))
(flan-dape-test--fail "no local %s of type %s; saw %S"
(nth 1 want) (nth 0 want) seen))))))))
(ignore-errors (dape-kill (dape--live-connection 'parent)))
(if (zerop flan-dape-test--failures)
(progn (message "flan-dape: all tests passed") (kill-emacs 0))
(message "%d failure(s)" flan-dape-test--failures)
(kill-emacs 1))
;;; test-flan-dape.el ends here

47
lib/build.ml
View File

@ -59,6 +59,19 @@ type opts = {
through a cell so a redefinition can be installed, and [-rdynamic] exports
those cells (and the globals) so a dlopen'd module can reach them. *)
dev : bool;
(* DWARF in the .ll and -g on the C, so lldb can put a breakpoint on a Flan
function by name and print its locals.
Its own axis, and deliberately not implied by -O0. The acceptance table
runs the same programs at -O0 and -O2 to compare the emitted IR against
what mem2reg makes of it, and if -O0 pulled in debug info every one of
those comparisons would be against a different module. It is not implied
by [dev] either: a dev build is about reloading, this is about reading,
and either is useful without the other. What it *does* imply, downwards,
is -O0 -- see [executable], where it sets [opt] -- because the whole
mechanism is a [llvm.dbg.declare] on an alloca and mem2reg deletes the
alloca. *)
debug : bool;
}
(* Checks are deliberately independent of [opt]: the acceptance table runs the
@ -66,7 +79,8 @@ type opts = {
makes of it, and that comparison is only meaningful if both emit the same
checks. Dropping them is a release decision, not an optimisation one. *)
let default =
{ target = None; opt = "-O2"; keep = false; checks = true; dev = false }
{ target = None; opt = "-O2"; keep = false; checks = true; dev = false;
debug = false }
(* ── wasm32, which needs more than a triple ──────────────────────────
The native target is whatever clang was built for, so [--target=] alone is
@ -264,6 +278,7 @@ let compile_c ~opts ?tflags ~src ~name () =
(Digest.string
(String.concat "\000"
[ name; src; Lazy.force clang_stamp; opts.opt;
(if opts.debug then "-g" else "");
String.concat " " tflags ]))
in
let obj = Filename.concat (cachedir ()) (key ^ ".o") in
@ -276,7 +291,9 @@ let compile_c ~opts ?tflags ~src ~name () =
let tmp = Printf.sprintf "%s.%d.tmp" obj (Unix.getpid ()) in
let cmd =
String.concat " "
([ Filename.quote clang; opts.opt; "-c" ] @ tflags
([ Filename.quote clang; opts.opt ]
@ (if opts.debug then [ "-g" ] else [])
@ [ "-c" ] @ tflags
@ [ Filename.quote c; "-o"; Filename.quote tmp ])
in
let code = Sys.command cmd in
@ -290,7 +307,7 @@ let compile_c ~opts ?tflags ~src ~name () =
(* [csrcs] and [lflags] come from the imported packages (see [Load]): the C
shim a package binds through, and the arguments needed to link the library
it binds to. *)
let executable ?(opts = default) ?(csrcs = []) ?(lflags = [])
let executable ?(opts = default) ?(csrcs = []) ?(lflags = []) ?(pnames = [])
(p : Tast.program) ~out =
(* A dev build is the REPL's, and the REPL reaches a running process through
[-rdynamic] and [dlopen]. Neither exists on wasm32, so the combination is
@ -299,10 +316,25 @@ let executable ?(opts = default) ?(csrcs = []) ?(lflags = [])
failwith
"wasm32: --dev is native only — the reload path is dlopen, which wasm32 \
has no equivalent of";
(* Refused rather than emitted-and-hoped-for. The member offsets in the DWARF
are computed for the host's layout — [ptr] 8 bytes — and wasm32's pointer
is 4, so a slice's [len] is at byte 8 there and at byte 16 here. Emitting
the host numbers would give a debugger a confident wrong answer for every
slice and every struct holding one, which is the failure this project
keeps meeting at the FFI boundary. *)
if wasm_target opts && opts.debug then
failwith
"wasm32: --debug is native only — the DWARF member offsets are computed \
for the host's layout, and wasm32's 32-bit pointer moves every one of \
them";
(* -O0 is not a choice a debug build offers: [llvm.dbg.declare] describes an
alloca, and at -O2 mem2reg deletes the alloca. *)
let opts = if opts.debug then { opts with opt = "-O0" } else opts in
let tflags = target_flags opts in
let dir = workdir () in
let ll = Filename.concat dir (Filename.basename out ^ ".ll") in
write ll (Emit.program ~checks:opts.checks ~dev:opts.dev p);
write ll
(Emit.program ~checks:opts.checks ~dev:opts.dev ~debug:opts.debug ~pnames 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 —
@ -313,6 +345,9 @@ let executable ?(opts = default) ?(csrcs = []) ?(lflags = [])
space and not binary size, and [-rdynamic] and the cells are still what
[--dev] means. *)
let cc src name = compile_c ~opts ~tflags ~src ~name () in
(* The runtime's own C wants -g too, or a backtrace that passes through
flan_error lands in a frame with no line. The flag is part of the object
cache key via [compile_c]'s [opt]/[tflags] digest — see [cflags]. *)
let objs =
cc Runtime_src.source "flan_rt.c"
:: [ cc Runtime_src.dev_source "flan_dev.c" ]
@ -332,6 +367,9 @@ let executable ?(opts = default) ?(csrcs = []) ?(lflags = [])
let cmd =
String.concat " "
([ Filename.quote clang; opts.opt; "-Wno-override-module" ]
(* -g at the link so clang does not strip, and keeps the object files'
debug sections; the .ll carries its own. *)
@ (if opts.debug then [ "-g" ] else [])
@ (if opts.dev then [ "-rdynamic" ] else [])
@ tflags
@ [ Filename.quote ll ]
@ -387,6 +425,7 @@ let run what cmd =
if code <> 0 then failwith (Printf.sprintf "%s failed (exit %d)" what code)
let shared ?(opts = default) ~ir ~out () : timing =
let opts = if opts.debug then { opts with opt = "-O0" } else opts in
if wasm_target opts then
failwith
"wasm32: the reload path is native only — it is llc + ld -shared + \

418
lib/emit.ml
View File

@ -100,6 +100,80 @@ let rec ll (t : Types.t) =
let is_void (t : Types.t) = match t with Types.Unit | Types.Never -> true | _ -> false
(* -- Debug info ----------------------------------------------------- *)
(* DWARF, as LLVM metadata. This is only worth the lines it takes because of
the layout above: a Flan struct *is* its C struct, every slot is an alloca
and there are no tag words, so the debug info describes machine types
directly and lldb has to learn nothing about Flan. The compile unit says
DW_LANG_C99 for that reason -- it is less a claim about the source language
than the truth about the data model, and it is what makes lldb's own
struct-printing correct here.
Metadata is a flat numbered pool with no ordering requirement, so a node can
be allocated an id, referred to, and written out later -- which is what
makes a recursive struct (a field of type [(Ptr Self)]) expressible. *)
type dbg = {
mutable dn : int; (* next metadata id *)
dout : Buffer.t; (* the [!N = ...] lines *)
dfiles : (string, int) Hashtbl.t; (* path -> !DIFile *)
dtys : (string, int) Hashtbl.t; (* Types.to_string -> a type node *)
dlocs : (string, int) Hashtbl.t; (* scope:line:col -> !DILocation *)
mutable dcu : int;
}
let dalloc d = let n = d.dn in d.dn <- n + 1; n
let dput d n body = Buffer.add_string d.dout (Printf.sprintf "!%d = %s\n" n body)
let dnode d body = let n = dalloc d in dput d n body; n
(* Metadata strings are C strings in the .ll grammar, so the two characters
that could end one have to be escaped. Flan names contain - ? > and /, none
of which do. *)
let dstr s =
let b = Buffer.create (String.length s + 2) in
String.iter
(fun c ->
if c = '"' || c = '\\' then (Buffer.add_char b '\\'; Buffer.add_char b c)
else Buffer.add_char b c)
s;
Buffer.contents b
let dfile d path =
match Hashtbl.find_opt d.dfiles path with
| Some n -> n
| None ->
let abs =
if Filename.is_relative path then Filename.concat (Sys.getcwd ()) path else path
in
let n =
dnode d
(Printf.sprintf "!DIFile(filename: \"%s\", directory: \"%s\")"
(dstr (Filename.basename abs)) (dstr (Filename.dirname abs)))
in
Hashtbl.replace d.dfiles path n;
n
(* -- Layout ----------------------------------------------------------
DWARF wants member offsets as integer literals: [!DIDerivedType(tag:
DW_TAG_member, offset: N)] takes a constant and nothing else, so the
[ptrtoint (ptr getelementptr ...)] form this file uses elsewhere for a size
is not accepted there and these have to be computed. That makes this the one
place in the backend where a layout number is worked out rather than handed
to LLVM, and it is exactly where a wrong answer shows up as a plausible
value printed for the wrong field. So the acceptance test checks every
offset against LLVM's own [getelementptr] answer for the same struct type,
not against a table written by the same hand as the code.
The rules are C's, which is what LLVM gives a non-packed literal struct:
natural alignment, each member at the next aligned offset, tail padding out
to the struct's own alignment. The numbers are the host's -- [ptr] is 8
bytes -- which is why [Build] refuses a debug build for wasm32. *)
let align_up x a = if a <= 1 then x else ((x + a - 1) / a) * a
(* ── Module-level state ────────────────────────────────────────────── *)
type m = {
@ -115,6 +189,10 @@ type m = {
(* Was this name in the build the running process came from? False only in a
redefinition module, and only for a name introduced since. *)
known : string -> bool;
(* [Some] in a debug build. It lives on the module rather than being passed
down because every emitter that can produce an instruction has to be able
to hang a location on it. *)
dbg : dbg option;
mutable nstr : int;
}
@ -122,6 +200,139 @@ let field_ty m sn i =
let s = Hashtbl.find m.structs sn in
(List.nth s.Tast.fields i).Tast.fty
(* Size and alignment in bytes. *)
let rec lay m (t : Types.t) : int * int =
match t with
| Types.Int k -> let n = Types.bits k / 8 in n, n
| Types.Float Types.F32 -> 4, 4
| Types.Float Types.F64 -> 8, 8
(* [i1] occupies a byte in memory. *)
| Types.Bool -> 1, 1
| Types.String | Types.Slice _ -> 16, 8
| Types.Unit | Types.Never -> 0, 1
| Types.Enum _ -> 4, 4
| Types.Ptr _ -> 8, 8
(* [n x T] adds no padding of its own: T's size already carries its tail. *)
| Types.Array (n, e) -> let s, a = lay m e in Int64.to_int n * s, a
| Types.Option e -> let s, a, _ = lay_fields m [ Types.Int Types.I8; e ] in s, a
| Types.Named n ->
(match Hashtbl.find_opt m.structs n with
| Some st ->
let s, a, _ =
lay_fields m (List.map (fun (fl : Tast.field) -> fl.Tast.fty) st.Tast.fields)
in
s, a
| None -> failwith ("no layout for struct " ^ n))
| Types.Map _ | Types.Fn _ | Types.Var _ ->
failwith ("no layout for " ^ Types.to_string t)
(* Size, alignment, and the offset of every member. *)
and lay_fields m tys =
let off = ref 0 and al = ref 1 and rev = ref [] in
List.iter
(fun t ->
let s, a = lay m t in
let a = if a < 1 then 1 else a in
off := align_up !off a;
rev := !off :: !rev;
off := !off + s;
if a > !al then al := a)
tys;
align_up !off !al, !al, List.rev !rev
(* A DWARF type node for a Flan type, memoised by the type's printed form so
the pool holds one node per distinct type. *)
let rec dty m d (t : Types.t) : int =
let key = Types.to_string t in
match Hashtbl.find_opt d.dtys key with
| Some n -> n
| None ->
let basic name bits enc =
dnode d
(Printf.sprintf "!DIBasicType(name: \"%s\", size: %d, encoding: %s)"
(dstr name) bits enc)
in
(* A struct-shaped node, with its id claimed before the members are built:
a field of type [(Ptr Self)] comes back through here. *)
let composite name members =
let id = dalloc d in
Hashtbl.replace d.dtys key id;
let size, al, offs = lay_fields m (List.map snd members) in
let ms =
List.map2
(fun (mname, mty) off ->
let fs, fa = lay m mty in
let base = dty m d mty in
dnode d
(Printf.sprintf
"!DIDerivedType(tag: DW_TAG_member, name: \"%s\", baseType: !%d, size: %d, align: %d, offset: %d)"
(dstr mname) base (fs * 8) (fa * 8) (off * 8)))
members offs
in
dput d id
(Printf.sprintf
"!DICompositeType(tag: DW_TAG_structure_type, name: \"%s\", size: %d, align: %d, elements: !{%s})"
(dstr name) (size * 8) (al * 8)
(String.concat ", " (List.map (fun i -> Printf.sprintf "!%d" i) ms)));
id
in
let n =
match t with
| Types.Int k ->
(* DW_ATE_signed / DW_ATE_unsigned, not the _char variants: an i8 is a
number in Flan, and lldb prints a character for a char. *)
basic (Types.to_string t) (Types.bits k)
(if Types.signed k then "DW_ATE_signed" else "DW_ATE_unsigned")
| Types.Float k -> basic (Types.to_string t) (Types.bits_f k) "DW_ATE_float"
| Types.Bool -> basic "bool" 8 "DW_ATE_boolean"
| Types.Enum e -> basic e 32 "DW_ATE_signed"
| Types.Unit | Types.Never -> composite (Types.to_string t) []
| Types.Ptr e ->
let id = dalloc d in
Hashtbl.replace d.dtys key id;
(* [(Ptr Unit)] and [(Ptr Never)] are the opaque pointer, and a DWARF
pointer with no base type is exactly C's void *. *)
let base =
match e with
| Types.Unit | Types.Never -> "null"
| e -> Printf.sprintf "!%d" (dty m d e)
in
dput d id
(Printf.sprintf
"!DIDerivedType(tag: DW_TAG_pointer_type, baseType: %s, size: 64)" base);
id
| Types.Array (n, e) ->
let base = dty m d e in
let size, al = lay m t in
let sub = dnode d (Printf.sprintf "!DISubrange(count: %Ld)" n) in
dnode d
(Printf.sprintf
"!DICompositeType(tag: DW_TAG_array_type, baseType: !%d, size: %d, align: %d, elements: !{!%d})"
base (size * 8) (al * 8) sub)
(* ptr+len, and shown as ptr+len. There is no hidden owner and no
capacity, so two members are the whole truth about a slice. *)
| Types.String ->
composite "string"
[ ("ptr", Types.Ptr (Types.Int Types.U8)); ("len", Types.Int Types.I64) ]
| Types.Slice e ->
composite (Types.to_string t)
[ ("ptr", Types.Ptr e); ("len", Types.Int Types.I64) ]
| Types.Option e ->
composite (Types.to_string t)
[ ("tag", Types.Int Types.U8); ("value", e) ]
| Types.Named sn ->
(match Hashtbl.find_opt m.structs sn with
| Some st ->
composite sn
(List.map (fun (fl : Tast.field) -> (fl.Tast.fname, fl.Tast.fty))
st.Tast.fields)
| None -> failwith ("no debug type for struct " ^ sn))
| Types.Map _ | Types.Fn _ | Types.Var _ ->
failwith ("no debug type for " ^ Types.to_string t)
in
Hashtbl.replace d.dtys key n;
n
(* ── Per-function state ────────────────────────────────────────────── *)
type f = {
@ -143,6 +354,17 @@ type f = {
unwind : string;
mutable unwound : bool;
defers : Tast.expr list;
(* The function's !DISubprogram, in a debug build, and the line it was
declared on -- the fallback for a node the checker made up. *)
dsub : int option;
dline : int;
(* The [, !dbg !N] suffix every instruction in this function carries, or "".
Uniform rather than only on the instructions that want a line: LLVM's
verifier rejects a call without a location inside a function that has
debug info, and this file emits calls from a dozen places -- the bounds
failure, the handler push and pop, the transfer guards -- none of which
would remember to ask. *)
mutable dloc : string;
}
let fresh f = f.n <- f.n + 1; Printf.sprintf "%%t%d" f.n
@ -151,11 +373,14 @@ 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. *)
let ins f fmt =
Printf.ksprintf (fun s -> if f.live then Buffer.add_string f.b (" " ^ s ^ "\n")) fmt
Printf.ksprintf
(fun s -> if f.live then Buffer.add_string f.b (" " ^ s ^ f.dloc ^ "\n")) fmt
let term f fmt =
Printf.ksprintf
(fun s -> if f.live then Buffer.add_string f.b (" " ^ s ^ "\n"); f.live <- false)
(fun s ->
if f.live then Buffer.add_string f.b (" " ^ s ^ f.dloc ^ "\n");
f.live <- false)
fmt
let label f name =
@ -280,7 +505,47 @@ let fcmp_op = function
| Tast.Le -> "ole" | Tast.Gt -> "ogt" | Tast.Ge -> "oge"
| _ -> assert false
(* 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*
a child -- the branch at the end of an [if], the store of a [set] -- are
attributed to the parent and not to whatever ran last inside it. *)
let rec value 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) =
match f.md.dbg, f.dsub with
| Some d, Some sub ->
(* Line 0 is [Loc.unknown] -- a node the checker made up rather than one
anyone wrote. It is attributed to the function's own line instead, since
a zero line in DWARF means "no line" and would make lldb step over the
whole construct. *)
let line = if loc.Loc.line = 0 then f.dline else loc.Loc.line in
let key = Printf.sprintf "%d:%d:%d" sub line loc.Loc.col in
let id =
match Hashtbl.find_opt d.dlocs key with
| Some id -> id
| None ->
let id =
dnode d
(Printf.sprintf "!DILocation(line: %d, column: %d, scope: !%d)"
line loc.Loc.col sub)
in
Hashtbl.replace d.dlocs key id; id
in
f.dloc <- Printf.sprintf ", !dbg !%d" id
| _ -> ()
and value_at f (e : Tast.expr) : string =
match e.Tast.e with
| Tast.Int (n, _) -> Int64.to_string n
| Tast.Float (x, k) -> float_const k x
@ -1036,8 +1301,27 @@ let signature ~named (fn : Tast.fn) =
visibility in a shared object is interposable: [@"flan.bump"] inside the
module would resolve to the *host's* copy, so the installer would publish
the function it was replacing and the reload would appear to do nothing. *)
let emit_fn m ?(hidden = false) (fn : Tast.fn) =
(* The name a slot goes into the debug info under. The typed IR refers to
locals by index and nothing records what they were called -- [Check] knows,
in its scope list, and drops it. So a parameter gets the name the source
gave it, recovered by the driver and handed down in [pnames], and everything
else gets [s<index>], which is the slot it actually is. A [let]-bound local
printing as [s4] is a real gap and it is named here rather than papered
over: fixing it means the typed IR carrying the name, which is a change to
[Tast]. *)
let slot_name ~pnames ~nparams i =
if i < nparams then
match List.nth_opt pnames i with
| Some n when n <> "" -> n
| _ -> Printf.sprintf "p%d" i
else Printf.sprintf "s%d" i
let emit_fn m ?(hidden = false) ?(pnames = []) (fn : Tast.fn) =
let n = Array.length fn.Tast.slots in
(* The subprogram's id is claimed before the body is emitted, because every
instruction in the body refers to it, and the node itself is written at
the end once the retained variables are known. *)
let dsub = match m.dbg with None -> None | Some d -> Some (dalloc d) in
let f = {
md = m;
allocas = Buffer.create 256;
@ -1048,6 +1332,9 @@ let emit_fn m ?(hidden = false) (fn : Tast.fn) =
slots = Array.init n (fun i -> Printf.sprintf "%%s%d" i);
slot_tys = fn.Tast.slots;
pads = []; unwind = "unwind"; unwound = false; defers = fn.Tast.fdefers;
dsub;
dline = (if fn.Tast.floc.Loc.line = 0 then 1 else fn.Tast.floc.Loc.line);
dloc = "";
} 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. *)
@ -1063,6 +1350,60 @@ let emit_fn m ?(hidden = false) (fn : Tast.fn) =
Buffer.add_string f.allocas
(Printf.sprintf " store %s %%p%d, ptr %s\n" (ll ty) i f.slots.(i)))
fn.Tast.params;
(* One [llvm.dbg.declare] per slot, in the entry block beside the alloca it
describes. This is the whole of what lldb needs to print a local: the slot
is ordinary stack storage of an ordinary machine type, so there is no
accessor to describe and no header to skip. *)
(match m.dbg, dsub with
| Some d, Some sub ->
let file = dfile d fn.Tast.floc.Loc.file in
let nparams = List.length fn.Tast.params in
let vars =
Array.to_list
(Array.mapi
(fun i ty ->
let arg =
(* [arg:] is 1-based over the LLVM formals, and the transfer
channel is appended after all of them, so a parameter's
index is its Flan index either way. The channel itself gets
no variable: nothing in the language can name it. *)
if i < nparams then Printf.sprintf ", arg: %d" (i + 1) else ""
in
dnode d
(Printf.sprintf
"!DILocalVariable(name: \"%s\"%s, scope: !%d, file: !%d, line: %d, type: !%d)"
(dstr (slot_name ~pnames ~nparams i)) arg sub file f.dline
(dty m d ty)))
fn.Tast.slots)
in
let dl =
dnode d
(Printf.sprintf "!DILocation(line: %d, column: 1, scope: !%d)" f.dline sub)
in
List.iteri
(fun i v ->
Buffer.add_string f.allocas
(Printf.sprintf
" call void @llvm.dbg.declare(metadata ptr %s, metadata !%d, metadata !DIExpression()), !dbg !%d\n"
f.slots.(i) v dl))
vars;
let sty =
dnode d
(Printf.sprintf "!DISubroutineType(types: !{%s})"
(String.concat ", "
((if is_void fn.Tast.ret then "null"
else Printf.sprintf "!%d" (dty m d fn.Tast.ret))
:: List.map (fun t -> Printf.sprintf "!%d" (dty m d t))
fn.Tast.params)))
in
dput d sub
(Printf.sprintf
"distinct !DISubprogram(name: \"%s\", linkageName: \"flan.%s\", scope: !%d, file: !%d, line: %d, type: !%d, scopeLine: %d, spFlags: DISPFlagDefinition, flags: DIFlagPrototyped, unit: !%d, retainedNodes: !{%s})"
(dstr fn.Tast.name) (dstr fn.Tast.name) file file f.dline sty f.dline
d.dcu
(String.concat ", " (List.map (fun v -> Printf.sprintf "!%d" v) vars)));
at_loc f fn.Tast.floc
| _ -> ());
let last = ref "zeroinitializer" in
List.iter (fun e -> last := value f e) fn.Tast.body;
(* A Unit function's body may end on a form of any type — the value is
@ -1102,8 +1443,9 @@ let emit_fn m ?(hidden = false) (fn : Tast.fn) =
end
end;
Buffer.add_string m.out
(Printf.sprintf "\ndefine %s%s {\nentry:\n%s%s}\n"
(Printf.sprintf "\ndefine %s%s%s {\nentry:\n%s%s}\n"
(if hidden then "hidden " else "") (signature ~named:true fn)
(match dsub with None -> "" | Some n -> Printf.sprintf " !dbg !%d" n)
(Buffer.contents f.allocas) (Buffer.contents f.b))
(* ── Globals ───────────────────────────────────────────────────────── *)
@ -1217,12 +1559,39 @@ let emit_main m (fn : Tast.fn) =
emitters look names up in, the struct types, and the foreign [declare]s.
Both entry points below start here, so a redefinition module cannot drift
from the whole-program one in how it names or lays out a type. *)
let new_module ~checks ~dev ~known (p : Tast.program) =
(* Which file the compile unit is about. Every subprogram carries its own
[!DIFile], so this only decides what a debugger calls the unit as a whole;
the first function anyone actually wrote is the honest answer. *)
let cu_file (p : Tast.program) =
match
List.find_opt (fun (f : Tast.fn) -> f.Tast.floc.Loc.line > 0) p.Tast.fns
with
| Some f -> f.Tast.floc.Loc.file
| None -> "<flan>"
let new_dbg (p : Tast.program) =
let d =
{ dn = 0; dout = Buffer.create 4096; dfiles = Hashtbl.create 8;
dtys = Hashtbl.create 32; dlocs = Hashtbl.create 256; dcu = 0 }
in
let file = dfile d (cu_file p) in
d.dcu <- dalloc d;
(* [isOptimized: false] is not decoration: it is what a debug build is, and
[Build] sets -O0 to make it true. DW_LANG_C99 because the layout is C's
and lldb's C support is then exactly right for it. *)
dput d d.dcu
(Printf.sprintf
"distinct !DICompileUnit(language: DW_LANG_C99, file: !%d, producer: \"flan\", isOptimized: false, runtimeVersion: 0, emissionKind: FullDebug, splitDebugInlining: false)"
file);
d
let new_module ~checks ~dev ~known ?(debug = false) (p : Tast.program) =
let m = {
out = Buffer.create 8192; strs = Buffer.create 512;
structs = Hashtbl.create 16; globals = Hashtbl.create 16;
externs = Hashtbl.create 32;
checks; dev; known; nstr = 0;
dbg = (if debug then Some (new_dbg p) else None);
} in
List.iter (fun (s : Tast.structure) -> Hashtbl.replace m.structs s.Tast.sname s)
p.Tast.structs;
@ -1257,12 +1626,32 @@ let new_module ~checks ~dev ~known (p : Tast.program) =
if p.Tast.externs <> [] then Buffer.add_char m.out '\n';
m
let finish m = header ^ Buffer.contents m.strs ^ "\n" ^ Buffer.contents m.out
(* The two named metadata nodes without which none of the above survives:
LLVM drops every scrap of debug metadata, silently and with no diagnostic,
if "Debug Info Version" is absent. A build that "works" and shows nothing in
the debugger is that flag. *)
let dmodule d =
let b = Buffer.create 512 in
Buffer.add_string b
"\ndeclare void @llvm.dbg.declare(metadata, metadata, metadata)\n\n";
let dv = dalloc d and div = dalloc d in
dput d dv "!{i32 7, !\"Dwarf Version\", i32 5}";
dput d div "!{i32 2, !\"Debug Info Version\", i32 3}";
Buffer.add_string b (Printf.sprintf "!llvm.dbg.cu = !{!%d}\n" d.dcu);
Buffer.add_string b
(Printf.sprintf "!llvm.module.flags = !{!%d, !%d}\n\n" dv div);
Buffer.add_buffer b d.dout;
Buffer.contents b
let finish m =
header ^ Buffer.contents m.strs ^ "\n" ^ Buffer.contents m.out
^ (match m.dbg with None -> "" | Some d -> dmodule d)
(* [checks] is on by default: a dev build traps on an out-of-bounds [at] or
[slice], a release build is told to drop them. *)
let program ?(checks = true) ?(dev = false) (p : Tast.program) : string =
let m = new_module ~checks ~dev ~known:(fun _ -> true) p in
let program ?(checks = true) ?(dev = false) ?(debug = false) ?(pnames = [])
(p : Tast.program) : string =
let m = new_module ~checks ~dev ~known:(fun _ -> true) ~debug 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. *)
@ -1276,7 +1665,13 @@ let program ?(checks = true) ?(dev = false) (p : Tast.program) : string =
Buffer.add_char m.out '\n'
end;
List.iter (emit_global m) p.Tast.globals;
List.iter (emit_fn m) p.Tast.fns;
List.iter
(fun (fn : Tast.fn) ->
emit_fn m
~pnames:(match List.assoc_opt fn.Tast.name pnames with
| Some ns -> ns | None -> [])
fn)
p.Tast.fns;
(match List.find_opt (fun (f : Tast.fn) -> f.Tast.name = "main") p.Tast.fns with
| Some fn -> emit_main m fn
| None -> ());
@ -1307,7 +1702,8 @@ let program ?(checks = true) ?(dev = false) (p : Tast.program) : string =
String literals still have to come along: they are this module's own
constants, and omitting them is an undefined [@.str.N] at link time. *)
let redefinition ?(checks = true) ?(dev = false) ?(known = fun _ -> true)
let redefinition ?(checks = true) ?(dev = false) ?(debug = false)
?(known = fun _ -> true)
?call ?(consts = []) (p : Tast.program) ~fns : string =
let target name =
match List.find_opt (fun (f : Tast.fn) -> f.Tast.name = name) p.Tast.fns with
@ -1332,7 +1728,7 @@ let redefinition ?(checks = true) ?(dev = false) ?(known = fun _ -> true)
let siblings =
List.filter (fun (f : Tast.fn) -> f.Tast.fparent = None) p.Tast.fns
in
let m = new_module ~checks ~dev ~known p in
let m = new_module ~checks ~dev ~known ~debug 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

25
test/programs/debug-permuted.flan Normal file
View File

@ -0,0 +1,25 @@
;;;; debug.flan with the fields of Cell in a different order and nothing else
;;;; changed. The program prints the same four lines; the struct is a different
;;;; shape, and every member sits at a different offset.
;;;;
;;;; name at 0 (16), id at 16, alive at 20, 3 of padding, heat at 24 — so a
;;;; DWARF offset table that is right for debug.flan is wrong for all four
;;;; members here, which is what makes the pair a test rather than an
;;;; observation.
(defstruct Cell [name string id i32 alive bool heat f64])
(defn tick [c (Ptr Cell) n i32] i32
(let [bump (+ n 1)]
(set (.heat c) (+ (.heat c) 1.5))
(set (.id c) bump)
bump))
(defn main [] i32
(let [c (Cell {:alive true :heat 3.25 :id 7 :name "grain"})]
(let [r (tick (addr c) 41)]
(print-i64 (i64 r)) (newline)
(print-f64 (.heat c)) (newline)
(print-i64 (i64 (.id c))) (newline)
(print-str (.name c)) (newline)
0)))

30
test/programs/debug.flan Normal file
View File

@ -0,0 +1,30 @@
;;;; The program the source-level debugging case runs under lldb.
;;;;
;;;; Every field holds a distinct known value of a distinct shape, so a DWARF
;;;; member offset that is wrong prints something obviously wrong rather than
;;;; something plausible — which is the failure mode this whole case exists
;;;; for. debug-permuted.flan is the same program with the fields declared in
;;;; a different order and every value unchanged: the two must print the same
;;;; field/value pairs from different offsets.
;;;;
;;;; alive at 0 (a byte), 7 of padding, heat at 8, id at 16, 4 of padding,
;;;; name at 24 — the slice is the member that moves if the alignment rule is
;;;; wrong, because it is the only one whose own alignment exceeds its first
;;;; member's size.
(defstruct Cell [alive bool heat f64 id i32 name string])
(defn tick [c (Ptr Cell) n i32] i32
(let [bump (+ n 1)]
(set (.heat c) (+ (.heat c) 1.5))
(set (.id c) bump)
bump))
(defn main [] i32
(let [c (Cell {:alive true :heat 3.25 :id 7 :name "grain"})]
(let [r (tick (addr c) 41)]
(print-i64 (i64 r)) (newline)
(print-f64 (.heat c)) (newline)
(print-i64 (i64 (.id c))) (newline)
(print-str (.name c)) (newline)
0)))

501
test/test_acceptance.ml
View File

@ -1043,6 +1043,507 @@ ERR@7 unexpected token: not the kind the caller was reading
outputs ~opt:"-O0" "a package struct in return position, -O0"
"programs/pkg-return.flan" pkgret_out;
(* -- Source-level debugging: DWARF, and whether it is true ---------
The whole of this section is about one risk. A Flan struct is its C
struct and lldb needs to learn nothing about the data model, which is
what makes DWARF cheap here; but !DIDerivedType takes its member offset
as an integer literal, so those offsets are the one layout number the
backend works out for itself instead of handing to LLVM. A wrong one
does not crash: it prints a plausible value for the wrong field, which
is the failure this project has met over and over at the FFI boundary.
So the offsets are not checked against a table written by the same hand
as the code. They are checked against LLVM's own answer for the same
struct type — ptrtoint of a getelementptr through a null pointer, which
is exactly the idiom Emit already uses for the size it passes to
flan_dev_global — constant-folded by llc into a .quad and read back.
And the whole thing is run twice over the same struct with its fields
permuted, because a check that cannot come out differently is not
checking anything. *)
(* Small text tools, since there is no Str and the reader is hand-written
for the same reason. *)
let lines_of s = String.split_on_char '\n' s in
let index_of hay needle =
let n = String.length needle and h = String.length hay in
let rec go i =
if i + n > h then -1 else if String.sub hay i n = needle then i else go (i + 1)
in
go 0
in
(* The value of [key: ] in a metadata node, up to the next , or ). *)
let attr line key =
let k = key ^ ": " in
match index_of line k with
| -1 -> None
| i ->
let i = i + String.length k in
let j = ref i in
let n = String.length line in
while !j < n && line.[!j] <> ',' && line.[!j] <> ')' do incr j done;
Some (String.sub line i (!j - i))
in
(* [elements: !{!12, !13}] — the value has commas in it, so it needs its
own reader rather than [attr]'s stop-at-the-next-comma. *)
let attr_ids line key =
let k = key ^ ": !{" in
match index_of line k with
| -1 -> []
| i ->
let i = i + String.length k in
let j = ref i and n = String.length line in
while !j < n && line.[!j] <> '}' do incr j done;
String.sub line i (!j - i)
|> String.split_on_char ','
|> List.filter_map (fun t ->
let t = String.trim t in
if String.length t > 1 && t.[0] = '!' then
int_of_string_opt (String.sub t 1 (String.length t - 1))
else None)
in
let unquote s =
let n = String.length s in
if n >= 2 && s.[0] = '"' && s.[n - 1] = '"' then String.sub s 1 (n - 2) else s
in
(* The parameter names come down from the driver, exactly as [bin/main.ml]
sends them: the typed IR does not carry them. *)
let pnames_of decls =
List.filter_map
(fun (d : Ast.decl) ->
match d.Ast.d with
| Ast.Defn fn ->
Some (fn.Ast.name,
List.map (fun (f : Ast.field) -> f.Ast.fname) fn.Ast.params)
| _ -> None)
decls
in
let debug_ir src =
let decls = Parse.program (Reader.read_all ~file:"<dwarf-test>" src) in
Emit.program ~debug:true ~pnames:(pnames_of decls) (Check.program decls)
in
(* Every (member name, byte offset) of a named struct, in declaration
order, as the emitted DWARF states it. *)
let dwarf_members ir sname =
let ls = lines_of ir in
let node id =
List.find_opt
(fun l -> String.starts_with ~prefix:(Printf.sprintf "!%d = " id) l) ls
in
let composite =
List.find_opt
(fun l ->
index_of l "!DICompositeType(tag: DW_TAG_structure_type" >= 0
&& attr l "name" = Some (Printf.sprintf "\"%s\"" sname))
ls
in
match composite with
| None -> None
| Some c ->
let ids = attr_ids c "elements" in
Some
((List.filter_map
(fun id ->
match node id with
| None -> None
| Some l ->
(match attr l "name", attr l "offset" with
| Some n, Some o ->
Some (unquote n, int_of_string (String.trim o) / 8)
| _ -> None))
ids),
(match attr c "size" with
| Some sz -> int_of_string (String.trim sz) / 8
| None -> -1))
in
(* LLVM's own answer, for the same struct type text the DWARF describes.
The type definitions are lifted straight out of the emitted module, so
there is no second spelling of the layout to get wrong. *)
let llvm_members ir sname nfields =
let tydefs =
lines_of ir
|> List.filter (fun l ->
String.length l > 0 && l.[0] = '%' && index_of l " = type " >= 0)
in
let sty = Printf.sprintf "%%\"%s\"" sname in
let b = Buffer.create 512 in
List.iter (fun l -> Buffer.add_string b (l ^ "\n")) tydefs;
for i = 0 to nfields - 1 do
Buffer.add_string b
(Printf.sprintf
"@o%d = constant i64 ptrtoint (ptr getelementptr (%s, ptr null, i32 0, i32 %d) to i64)\n"
i sty i)
done;
Buffer.add_string b
(Printf.sprintf
"@sz = constant i64 ptrtoint (ptr getelementptr (%s, ptr null, i32 1) to i64)\n"
sty);
let ll = Filename.concat scratch "flan-dwarf-oracle.ll" in
let asm = Filename.concat scratch "flan-dwarf-oracle.s" in
Out_channel.with_open_bin ll (fun ch -> Out_channel.output_string ch (Buffer.contents b));
let llc = try Sys.getenv "FLAN_LLC" with Not_found -> "llc" in
let code =
Sys.command
(Printf.sprintf "%s -filetype=asm %s -o %s > /dev/null 2>&1"
(Filename.quote llc) (Filename.quote ll) (Filename.quote asm))
in
if code <> 0 then None
else begin
let text = In_channel.with_open_bin asm In_channel.input_all in
(try Sys.remove ll with Sys_error _ -> ());
(try Sys.remove asm with Sys_error _ -> ());
(* llc writes the folded constant as ".quad 0+24" — a sum, because the
null base is still a symbolic zero to the assembler. *)
let pending = ref "" and acc = ref [] in
List.iter
(fun l ->
let t = String.trim l in
if String.length t > 1 && t.[String.length t - 1] = ':' then
pending := String.sub t 0 (String.length t - 1)
else if index_of t ".quad" >= 0 && !pending <> "" then begin
let v = String.trim (String.sub t 5 (String.length t - 5)) in
let v = match index_of v "#" with -1 -> v | i -> String.sub v 0 i in
let n =
String.split_on_char '+' v
|> List.fold_left
(fun a part ->
match int_of_string_opt (String.trim part) with
| Some x -> a + x
| None -> a)
0
in
acc := (!pending, n) :: !acc;
pending := ""
end)
(lines_of text);
Some (List.rev !acc)
end
in
(* The case itself: the DWARF a source text produces must agree with LLVM
on every member's offset, and on the struct's size. *)
let layout_case name src sname fields =
let ir = debug_ir src in
match dwarf_members ir sname with
| None ->
incr failures;
Printf.printf "FAIL %s\n no DWARF type for %s\n" name sname
| Some (members, size) ->
let got = List.map fst members in
if got <> fields then begin
incr failures;
Printf.printf "FAIL %s\n DWARF members: %s\n wanted: %s\n"
name (String.concat " " got) (String.concat " " fields)
end;
(match llvm_members ir sname (List.length fields) with
| None ->
(* No llc is a reason to skip the oracle, not to pass silently. *)
Printf.printf "acceptance: %s — llc unavailable, offsets unchecked\n" name
| Some oracle ->
List.iteri
(fun i (fname, off) ->
match List.assoc_opt (Printf.sprintf "o%d" i) oracle with
| None -> ()
| Some want ->
if off <> want then begin
incr failures;
Printf.printf
"FAIL %s\n %s.%s at byte %d in the DWARF, %d in LLVM\n"
name sname fname off want
end)
members;
(match List.assoc_opt "sz" oracle with
| Some want when want <> size ->
incr failures;
Printf.printf
"FAIL %s\n %s is %d bytes in the DWARF, %d in LLVM\n"
name sname size want
| _ -> ()));
()
in
let cell = "(defstruct Cell [alive bool heat f64 id i32 name string])\n" in
let cell' = "(defstruct Cell [name string id i32 alive bool heat f64])\n" in
let body = "(defn main [] i32 (let [c (Cell {:id 1})] (i32 (.id c))))\n" in
layout_case "DWARF offsets agree with LLVM: a mixed struct" (cell ^ body)
"Cell" [ "alive"; "heat"; "id"; "name" ];
(* The same struct, permuted. If the offsets came from anywhere but the
declaration order they would survive this, and they do not. *)
layout_case "DWARF offsets agree with LLVM: the same fields permuted"
(cell' ^ body) "Cell" [ "name"; "id"; "alive"; "heat" ];
layout_case "DWARF offsets agree with LLVM: nesting and fixed arrays"
("(defstruct P [x i32 y i32])\n\
(defstruct Board [tag u8 cells [4 P] here P edge (Ptr P) seen (Option i64)])\n\
(defn main [] i32 (let [b (Board {:tag 1})] (i32 (.tag b))))\n")
"Board" [ "tag"; "cells"; "here"; "edge"; "seen" ];
(* Permuting the fields must actually move them. Asserting that the two
orderings disagree is what makes the two cases above a test: an offset
table that ignored declaration order would satisfy both. *)
(match dwarf_members (debug_ir (cell ^ body)) "Cell",
dwarf_members (debug_ir (cell' ^ body)) "Cell" with
| Some (a, _), Some (b, _) ->
let off l n = List.assoc_opt n l in
if List.for_all (fun n -> off a n = off b n) [ "alive"; "heat"; "id"; "name" ]
then begin
incr failures;
print_endline
"FAIL permuting a defstruct left every DWARF offset unchanged"
end
| _ ->
incr failures;
print_endline "FAIL permuting a defstruct: no DWARF type for Cell");
(* A slot's *type* has to be right too, not only where it sits. These are
the shapes lldb has to render, and the layout table says what each one
weighs; a wrong size there is a truncated or over-read value. *)
let ir = debug_ir (cell ^ body) in
List.iter
(fun (needle, what) ->
if not (contains ir needle) then begin
incr failures;
Printf.printf "FAIL DWARF for %s\n wanted: %S\n" what needle
end)
[ ("!DIBasicType(name: \"i32\", size: 32, encoding: DW_ATE_signed)", "i32");
("!DIBasicType(name: \"u8\", size: 8, encoding: DW_ATE_unsigned)", "u8");
("!DIBasicType(name: \"f64\", size: 64, encoding: DW_ATE_float)", "f64");
(* A byte in memory, not a bit: an i1 alloca is one byte wide. *)
("!DIBasicType(name: \"bool\", size: 8, encoding: DW_ATE_boolean)", "bool");
(* ptr+len, and shown as ptr+len — there is no owner and no capacity
to hide, so two members are the whole truth about a string. *)
("name: \"string\", size: 128", "string");
(* A let-bound local has no name to keep: the typed IR refers to
slots by index and [Check] drops what they were called, so it is
emitted as the slot it is. Asserted rather than left implicit,
because this is the one honest gap in the picture. *)
("!DILocalVariable(name: \"s0\"", "a let-bound local, named by its slot");
("!llvm.dbg.cu = ", "the compile unit is registered");
(* Without this LLVM discards every node above, silently. *)
("!{i32 2, !\"Debug Info Version\", i32 3}", "the module flag") ];
(* Parameters carry the name the source gave them. The typed IR does not
record it — [Check] has it and drops it — so this is the driver handing
the names down, and it is worth a test because the path is easy to
forget when either end changes. *)
let ir =
debug_ir "(defn dist [ax f64 ay f64] f64 (+ ax ay))\n\
(defn main [] i32 (i32 (i64 (dist 1.0 2.0))))\n"
in
List.iter
(fun needle ->
if not (contains ir needle) then begin
incr failures;
Printf.printf "FAIL parameter names in DWARF\n wanted: %S\n" needle
end)
[ "!DILocalVariable(name: \"ax\", arg: 1"; "!DILocalVariable(name: \"ay\", arg: 2" ];
(* The transfer channel is a parameter of every Flan function and is not a
Flan name, so it gets no variable at all — and must not, or it would
take arg: 1 and shift every real parameter's storage by one. *)
if contains ir "name: \"xfer\"" then begin
incr failures;
print_endline "FAIL the transfer channel appeared as a local variable"
end;
(* LLVM's own verifier, over both entry points. String needles cannot see
a DISubprogram the compile unit does not reach, or a call without a
!dbg inside a function that has debug info — and that second one is a
hard rejection, not a warning, so it would turn every debug build into
a clang error rather than into anything visible here.
[redefinition] is the half that needs this most. It is only ever run at
the default debug:false today, and it differs from [program] in exactly
the places metadata goes wrong: hidden bodies, the by-name cell and
global loads, and flan_reload_install and flan_reload_call, which are
raw defines with no subprogram that nonetheless contain calls. *)
if Sys.command "command -v opt > /dev/null 2>&1" = 0 then begin
let verifies name ir =
let f = Filename.concat scratch "flan-dwarf-verify.ll" in
Out_channel.with_open_bin f (fun ch -> Out_channel.output_string ch ir);
let log = Filename.concat scratch "flan-dwarf-verify.log" in
let code =
Sys.command
(Printf.sprintf "opt -passes=verify -disable-output %s > %s 2>&1"
(Filename.quote f) (Filename.quote log))
in
if code <> 0 then begin
incr failures;
Printf.printf "FAIL %s: LLVM's verifier rejected the module\n%s\n" name
(In_channel.with_open_bin log In_channel.input_all)
end;
(try Sys.remove f with Sys_error _ -> ());
(try Sys.remove log with Sys_error _ -> ())
in
(* A program with a bit of everything that emits a call the backend
invents rather than one a Tast node asked for: a bounds check, a
condition signalled and handled, a restart transferred to, a defer on
the way out. Each would be a verifier rejection without a location. *)
let src =
"(defstruct Missing [id i32])\n\
(defvar seen i64)\n\
(defvar arr [4 i32])\n\
(defn pick [xs [i32] i i32] i32 (at xs i))\n\
(defn fetch [n i32] i32\n\
\ (restart-case\n\
\ (do (error (Missing {:id n})) 0)\n\
\ (use-placeholder [] -1)))\n\
(defn run [] i32\n\
\ (defer (set seen (+ seen 1)))\n\
\ (handler-bind [(Missing [m] (invoke-restart 'use-placeholder))]\n\
\ (fetch 3)))\n\
(defn main [] i32\n\
\ (set (at arr 2) 9)\n\
\ (let [s (slice arr 0 4)]\n\
\ (print-i64 (i64 (pick s 2))) (newline)\n\
\ (print-i64 (i64 (run))) (newline)\n\
\ 0))\n"
in
let decls = Parse.program (Reader.read_all ~file:"<verify>" src) in
let p = Check.program decls in
verifies "the whole program, with debug info"
(Emit.program ~debug:true ~pnames:(pnames_of decls) p);
(* And a redefinition module against a host that has every name — the
shape C-c C-c produces. *)
verifies "a redefinition module, with debug info"
(Emit.redefinition ~dev:true ~debug:true ~known:(fun _ -> true) p
~fns:[ "fetch"; "run" ]);
(* And one against a host that has none of them, which is the other
path: every call goes through flan_dev_cell and every global through
flan_dev_global, so the module is almost entirely different code. *)
verifies "a redefinition of names the host does not have"
(Emit.redefinition ~dev:true ~debug:true ~known:(fun _ -> false) p
~fns:[ "fetch"; "run" ])
end
else print_endline "acceptance: the DWARF verifier cases skipped (no opt)";
(* A debug build and a release build must still be the same program. *)
let debug_compile ?(dev = false) path =
let exe =
Filename.concat scratch
("flan-dbg-" ^ Filename.remove_extension (Filename.basename path)
^ if dev then "-dev" else "")
in
let l = Load.program ~file:path (Parse.program (Reader.read_file path)) in
let p = Check.program l.Load.decls in
let pnames =
List.filter_map
(fun (d : Ast.decl) ->
match d.Ast.d with
| Ast.Defn fn ->
Some (fn.Ast.name,
List.map (fun (f : Ast.field) -> f.Ast.fname) fn.Ast.params)
| _ -> None)
l.Load.decls
in
let p, csrcs, lflags = Reach.link ~dev l p in
ignore
(Build.executable ~opts:{ Build.default with debug = true; dev }
~csrcs ~lflags ~pnames p ~out:exe);
exe
in
let expected = "42\n4.75\n42\ngrain\n" in
List.iter
(fun path ->
let exe = debug_compile path in
let code, text = run exe None in
if text <> expected || code <> 0 then begin
incr failures;
Printf.printf
"FAIL a --debug build of %s runs the same\n got: %S (exit %d)\n wanted: %S\n"
path text code expected
end)
[ "programs/debug.flan"; "programs/debug-permuted.flan" ];
(* wasm32 is refused by name. The offsets above are the host's, and
wasm32's 32-bit pointer moves every slice member; emitting them anyway
would give a debugger a confident wrong answer. *)
(match
Build.executable
~opts:{ Build.default with debug = true; target = Some "wasm32-wasi" }
{ Tast.structs = []; unions = []; globals = []; externs = []; fns = [];
cshim = [] }
~out:(Filename.concat scratch "flan-dbg-wasm")
with
| _ ->
incr failures;
print_endline "FAIL --debug --target=wasm32-wasi was accepted"
| exception Failure m ->
if not (contains m "--debug is native only") then begin
incr failures;
Printf.printf "FAIL --debug on wasm32\n said: %S\n" m
end);
(* -- lldb, for real ------------------------------------------------
Everything above is about the metadata being self-consistent. This is
the only part that says a person can debug a Flan program: a breakpoint
set on a Flan function *by name*, a backtrace with .flan files and line
numbers, and locals printed with their own types and values. It is
skipped rather than failed where there is no lldb. *)
if Sys.command "command -v lldb > /dev/null 2>&1" = 0 then begin
let lldb_run exe cmds =
let out = Filename.concat scratch "flan-lldb.out" in
let code =
Sys.command
(Printf.sprintf "lldb -b %s %s > %s 2>&1"
(String.concat " "
(List.map (fun c -> "-o " ^ Filename.quote c) cmds))
(Filename.quote exe) (Filename.quote out))
in
let text = In_channel.with_open_bin out In_channel.input_all in
(try Sys.remove out with Sys_error _ -> ());
(code, text)
in
let lldb_case name path needles =
let exe = debug_compile path in
let _, text =
lldb_run exe
[ "breakpoint set --name flan.tick"; "run"; "bt"; "frame variable";
"p *c" ]
in
List.iter
(fun n ->
if not (contains text n) then begin
incr failures;
Printf.printf "FAIL %s\n wanted %S in lldb's output\n"
name n;
print_endline text
end)
needles
in
(* The four claims, one needle each: the breakpoint resolved on a Flan
name; the frame names a .flan file and a line inside tick; the caller
is the Flan main and not a C frame; a parameter prints by its source
name; and the struct through the pointer prints every field with the
value the program put there. *)
lldb_case "lldb: breakpoint, frames and locals" "programs/debug.flan"
[ "flan.tick"; "at debug.flan:"; "flan.main at debug.flan:";
"(int) n = 41"; "alive = true"; "heat = 3.25"; "id = 7"; "len = 5" ];
(* And the same, with the fields permuted. If the offsets were not
following the declaration, the values would land on the wrong names
here and nowhere else. *)
lldb_case "lldb: the same struct with its fields permuted"
"programs/debug-permuted.flan"
[ "at debug-permuted.flan:"; "flan.main at debug-permuted.flan:";
"(int) n = 41"; "alive = true"; "heat = 3.25"; "id = 7"; "len = 5" ];
(* A dev build routes every call through a cell, so the call site is an
indirect call through a mutable global. The frame above it is still
the Flan caller with its own line: the indirection is in how the
callee is found, not in how the frame is laid out, so nothing about
unwinding changes. Worth pinning, because "the stack goes missing
under --dev" would be the sort of thing found late. *)
let exe = debug_compile ~dev:true "programs/debug.flan" in
let _, text =
lldb_run exe [ "breakpoint set --name flan.tick"; "run"; "bt" ]
in
List.iter
(fun n ->
if not (contains text n) then begin
incr failures;
Printf.printf
"FAIL lldb: --dev --debug keeps the Flan stack\n wanted %S\n"
n;
print_endline text
end)
[ "flan.tick"; "flan.main at debug.flan:" ]
end
else print_endline "acceptance: lldb cases skipped (no lldb on PATH)";
if !failures = 0 then print_endline "acceptance: all tests passed"
else begin
Printf.printf "\n%d failure(s)\n" !failures;