diff --git a/bin/main.ml b/bin/main.ml index 9cd06fb..a77137e 100644 --- a/bin/main.ml +++ b/bin/main.ml @@ -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 [-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) ...\n\ \ flan build [-o out] [--no-bounds-checks] [--dev] \ - [--target=wasm32-wasi]\n\ + [--debug] [--target=wasm32-wasi]\n\ \ flan run [args...]\n\ \ flan reload [-o out.so]\n\ \ flan dev [-s socket]"; diff --git a/emacs/flan-dape.el b/emacs/flan-dape.el new file mode 100644 index 0000000..84def30 --- /dev/null +++ b/emacs/flan-dape.el @@ -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 diff --git a/emacs/test-flan-dape.el b/emacs/test-flan-dape.el new file mode 100644 index 0000000..3b32e09 --- /dev/null +++ b/emacs/test-flan-dape.el @@ -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 diff --git a/lib/build.ml b/lib/build.ml index 6bd3a2c..48df980 100644 --- a/lib/build.ml +++ b/lib/build.ml @@ -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 + \ diff --git a/lib/emit.ml b/lib/emit.ml index d2460e9..3a85c50 100644 --- a/lib/emit.ml +++ b/lib/emit.ml @@ -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], 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 -> "" + +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 diff --git a/test/programs/debug-permuted.flan b/test/programs/debug-permuted.flan new file mode 100644 index 0000000..fe2c371 --- /dev/null +++ b/test/programs/debug-permuted.flan @@ -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))) diff --git a/test/programs/debug.flan b/test/programs/debug.flan new file mode 100644 index 0000000..bfb5bce --- /dev/null +++ b/test/programs/debug.flan @@ -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))) diff --git a/test/test_acceptance.ml b/test/test_acceptance.ml index ec28dc1..f5f8b1d 100644 --- a/test/test_acceptance.ml +++ b/test/test_acceptance.ml @@ -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:"" 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:"" 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;