From 3b8a0cb553b46a7f3988b67ba6fe212d2aad764a Mon Sep 17 00:00:00 2001 From: Joseph Ferano Date: Sat, 12 Sep 2026 03:38:42 +0700 Subject: [PATCH 1/5] The positions were always there; write them out MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Every Tast node carries a Loc and nothing ever used one outside an error message, so a Flan program under a debugger was a wall of addresses. This emits DWARF for them. The reason it is a few hundred lines and not a few thousand is the layout. A Flan struct is its C struct, every slot is an alloca and there are no tag words, so there is nothing to describe *about Flan* — DW_LANG_C99 and the machine types are the honest answer, and lldb's own C support is then exactly right for a Flan value. Two things are load-bearing and neither is obvious: Debug Info Version in llvm.module.flags. Without it LLVM drops every scrap of debug metadata with no diagnostic at all, so the build succeeds and the debugger shows nothing and there is no thread to pull. A !dbg on every instruction, not only the ones that want a line. The 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 have remembered to ask. So the location lives on the per-function state and `ins` appends it. The member offsets are computed here rather than handed to LLVM, which is the one place in this backend that happens and so the one place a layout bug can hide. !DIDerivedType takes offset: as an integer literal; the ptrtoint-of-gep form this file uses elsewhere for a size is not accepted in metadata. The acceptance test therefore checks each one against LLVM's own getelementptr answer for the same struct type, not against a table written by the same hand. Local names are the gap. The typed IR refers to slots by index and records no names — Check has them and drops them — so a parameter gets its source name, recovered by the driver from declarations already in hand, and everything else gets s, which is the slot it actually is. Closing that means Tast carrying the name. --- lib/emit.ml | 418 ++++++++++++++++++++++++++++++++++++++++++++++++++-- 1 file changed, 407 insertions(+), 11 deletions(-) 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 From ba2f5bc9bb9d37ddeab2c043c8724d48f2dcea70 Mon Sep 17 00:00:00 2001 From: Joseph Ferano Date: Sat, 12 Sep 2026 03:38:53 +0700 Subject: [PATCH 2/5] Debugging is its own axis, not a mode of --dev or of -O0 MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --debug is a third flag beside --dev and the optimisation level because it answers a third question. --dev is "can I redefine this while it runs"; --debug is "can I stop it and read it". Either is useful without the other, and a REPL session that is not being stepped should not pay for DWARF. Not implied by -O0 in particular, for a reason already written down in this file: the acceptance table runs the same programs at -O0 and -O2 to compare the emitted IR against what mem2reg makes of it. If -O0 pulled in debug info, every one of those comparisons would be against a different module. It does imply -O0 downwards, and sets it. The whole mechanism is an llvm.dbg.declare hanging off an alloca, and mem2reg deletes the alloca. Refused for wasm32 by name. The member offsets in the DWARF are computed for the host — ptr is 8 bytes — and wasm32's pointer is 4, so a slice's len sits at byte 8 there and byte 16 here. Emitting the host numbers would hand a debugger a confident wrong answer for every slice and every struct holding one, which is the exact failure this project keeps meeting at the FFI boundary. Silence would be worse than the refusal. -g reaches the C compiles too, and joins compile_c's digest key with it, or an object built without it would be served to a build that asked for it. --- bin/main.ml | 44 ++++++++++++++++++++++++++++++++++++++------ lib/build.ml | 47 +++++++++++++++++++++++++++++++++++++++++++---- 2 files changed, 81 insertions(+), 10 deletions(-) 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/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 + \ From 67aa82457d03cc2010b2a69543a6a3ef792c0f6c Mon Sep 17 00:00:00 2001 From: Joseph Ferano Date: Sat, 12 Sep 2026 03:46:23 +0700 Subject: [PATCH 3/5] Check the offsets against LLVM, not against the same hand that wrote them MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit A wrong DWARF member offset does not crash anything. It prints a plausible value for the wrong field, which is the failure this project has met over and over at the FFI boundary, and it is the only way the debug info can be wrong without saying so. A table of expected offsets written in this test would be wrong in exactly the ways the code is wrong, so it checks against LLVM instead: ptrtoint of a getelementptr through a null pointer, over the struct type text lifted out of the emitted module, folded by llc into a .quad and read back. That is the same idiom Emit already uses for the size it hands flan_dev_global — it is just not expressible inside metadata, where offset: must be an integer literal. Then the same struct again with its fields permuted, and an assertion that the two disagree. A check that cannot come out differently is not checking anything: an offset table that ignored declaration order would satisfy either ordering alone. It fails when it should. Making a slice 4-byte aligned moves Cell.name from 24 to 20; the test says so by name, and lldb — which is the point — prints len = 21474836480 for a five-character string. The lldb cases are the only ones that say a person can debug a Flan program rather than that the metadata is self-consistent: a breakpoint on a Flan function by name, a backtrace naming .flan files and lines, and locals with their own types and values. Skipped where there is no lldb, since it is not a build dependency. The --dev case is there because "the stack goes missing under --dev" is the sort of thing found late. It does not: a cell changes how the callee is found, not how the frame is laid out. --- test/programs/debug-permuted.flan | 25 ++ test/programs/debug.flan | 30 +++ test/test_acceptance.ml | 430 ++++++++++++++++++++++++++++++ 3 files changed, 485 insertions(+) create mode 100644 test/programs/debug-permuted.flan create mode 100644 test/programs/debug.flan 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; From 5f5cc8bee91b00f660bc525d6ebaa841f63cd84d Mon Sep 17 00:00:00 2001 From: Joseph Ferano Date: Sat, 12 Sep 2026 03:58:26 +0700 Subject: [PATCH 4/5] lldb already speaks DAP; Emacs only needs to be told how to build MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit No DAP implementation here, and there should not be one. `flan build --debug' puts DWARF in the executable, lldb reads it, lldb-dap speaks the protocol — so what was actually missing was a dape-configs entry that knows to build a .flan file first and where the binary lands. The build goes through dape's own `compile' key rather than a shell-out, so a rejected program lands in a compilation buffer and next-error walks it. Flan's diagnostics are already file:line:col. `flan-debug' goes through `dape--config-eval' and not `alist-get'. `dape' takes a config whose forms are already evaluated — that is what M-x 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. Driven headlessly to prove it: a breakpoint set by line in the .flan buffer, hit, reported as flan.tick at debug.flan:19 with c and n in scope. The keybinding is registered from here rather than in flan-mode.el, so this file is the only thing anyone has to load to get it and flan-mode keeps working for someone who never installs dape. The two frictions are written down at the bottom of flan-dape.el from lldb transcripts, not from reasoning about what ought to happen, because the guess I started from was wrong. Across a reload a breakpoint set by *name* gains a second location and both stay live — the old body is still mapped and still what old call sites reach. One set by *file and line* stops firing, and not because dape pinned it to an address: the redefinition module has no line table to resolve against. Given one, lldb does re-resolve on dlopen. Which names the gap: Emit.redefinition takes ~debug and Session.eval does not pass it, so `flan reload' and the `flan dev' daemon build modules without DWARF. lib/session.ml is the dev loop's file, not this lane's. test-flan-dape.el is not in dune test. It wants Emacs, dape, lldb-dap and a built flan at once, and wiring four optional things into the acceptance table would make that table's failures mean less, not more. --- emacs/flan-dape.el | 229 ++++++++++++++++++++++++++++++++++++++++ emacs/test-flan-dape.el | 138 ++++++++++++++++++++++++ 2 files changed, 367 insertions(+) create mode 100644 emacs/flan-dape.el create mode 100644 emacs/test-flan-dape.el 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 From e3f352321d9059c7b6f31cab44eaa6b2a6b10089 Mon Sep 17 00:00:00 2001 From: Joseph Ferano Date: Sat, 12 Sep 2026 04:00:24 +0700 Subject: [PATCH 5/5] Run the verifier, because string needles cannot see what breaks MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit A call without a !dbg inside a function that has debug info is a hard LLVM rejection, not a warning — it turns every debug build into a clang error. So is a DISubprogram the compile unit does not reach. Neither is visible to an assertion about the text of the module, and both are the kind of thing that appears when this file grows a new call from somewhere other than a Tast node. The program the cases run through is chosen for those calls specifically: a bounds check, a condition signalled and handled, a restart transferred to, a defer on the way out. Every one of them is a call the backend invents. Emit.redefinition is the half that needed this. It had only ever run at the default debug:false, and it differs from Emit.program in exactly the places metadata goes wrong: hidden bodies, the by-name cell and global lookups, and flan_reload_install and flan_reload_call, which are raw defines with no subprogram that nonetheless contain calls. Both directions of `known' are covered, because they emit almost entirely different code. --- test/test_acceptance.ml | 71 +++++++++++++++++++++++++++++++++++++++++ 1 file changed, 71 insertions(+) diff --git a/test/test_acceptance.ml b/test/test_acceptance.ml index 4271d21..5d5ae0c 100644 --- a/test/test_acceptance.ml +++ b/test/test_acceptance.ml @@ -1157,6 +1157,77 @@ ERR@7 unexpected token: not the kind the caller was reading 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 =