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 85a45e3..4271d21 100644 --- a/test/test_acceptance.ml +++ b/test/test_acceptance.ml @@ -859,6 +859,436 @@ ERR@7 unexpected token: not the kind the caller was reading "(declare-c a [] \"Same\")\n(declare-c b [] \"Same\")" "one declare-c per C function"; + (* -- 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; + + (* 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;