The positions were always there; write them out
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<index>, which is the slot it actually is. Closing that means Tast carrying the name.
This commit is contained in:
parent
5f0bde8149
commit
3b8a0cb553
418
lib/emit.ml
418
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<index>], which is the slot it actually is. A [let]-bound local
|
||||
printing as [s4] is a real gap and it is named here rather than papered
|
||||
over: fixing it means the typed IR carrying the name, which is a change to
|
||||
[Tast]. *)
|
||||
let slot_name ~pnames ~nparams i =
|
||||
if i < nparams then
|
||||
match List.nth_opt pnames i with
|
||||
| Some n when n <> "" -> n
|
||||
| _ -> Printf.sprintf "p%d" i
|
||||
else Printf.sprintf "s%d" i
|
||||
|
||||
let emit_fn m ?(hidden = false) ?(pnames = []) (fn : Tast.fn) =
|
||||
let n = Array.length fn.Tast.slots in
|
||||
(* The subprogram's id is claimed before the body is emitted, because every
|
||||
instruction in the body refers to it, and the node itself is written at
|
||||
the end once the retained variables are known. *)
|
||||
let dsub = match m.dbg with None -> None | Some d -> Some (dalloc d) in
|
||||
let f = {
|
||||
md = m;
|
||||
allocas = Buffer.create 256;
|
||||
@ -1048,6 +1332,9 @@ let emit_fn m ?(hidden = false) (fn : Tast.fn) =
|
||||
slots = Array.init n (fun i -> Printf.sprintf "%%s%d" i);
|
||||
slot_tys = fn.Tast.slots;
|
||||
pads = []; unwind = "unwind"; unwound = false; defers = fn.Tast.fdefers;
|
||||
dsub;
|
||||
dline = (if fn.Tast.floc.Loc.line = 0 then 1 else fn.Tast.floc.Loc.line);
|
||||
dloc = "";
|
||||
} in
|
||||
(* Every slot is an alloca in the entry block, because [addr] may take the
|
||||
address of any of them and mem2reg only promotes entry-block allocas. *)
|
||||
@ -1063,6 +1350,60 @@ let emit_fn m ?(hidden = false) (fn : Tast.fn) =
|
||||
Buffer.add_string f.allocas
|
||||
(Printf.sprintf " store %s %%p%d, ptr %s\n" (ll ty) i f.slots.(i)))
|
||||
fn.Tast.params;
|
||||
(* One [llvm.dbg.declare] per slot, in the entry block beside the alloca it
|
||||
describes. This is the whole of what lldb needs to print a local: the slot
|
||||
is ordinary stack storage of an ordinary machine type, so there is no
|
||||
accessor to describe and no header to skip. *)
|
||||
(match m.dbg, dsub with
|
||||
| Some d, Some sub ->
|
||||
let file = dfile d fn.Tast.floc.Loc.file in
|
||||
let nparams = List.length fn.Tast.params in
|
||||
let vars =
|
||||
Array.to_list
|
||||
(Array.mapi
|
||||
(fun i ty ->
|
||||
let arg =
|
||||
(* [arg:] is 1-based over the LLVM formals, and the transfer
|
||||
channel is appended after all of them, so a parameter's
|
||||
index is its Flan index either way. The channel itself gets
|
||||
no variable: nothing in the language can name it. *)
|
||||
if i < nparams then Printf.sprintf ", arg: %d" (i + 1) else ""
|
||||
in
|
||||
dnode d
|
||||
(Printf.sprintf
|
||||
"!DILocalVariable(name: \"%s\"%s, scope: !%d, file: !%d, line: %d, type: !%d)"
|
||||
(dstr (slot_name ~pnames ~nparams i)) arg sub file f.dline
|
||||
(dty m d ty)))
|
||||
fn.Tast.slots)
|
||||
in
|
||||
let dl =
|
||||
dnode d
|
||||
(Printf.sprintf "!DILocation(line: %d, column: 1, scope: !%d)" f.dline sub)
|
||||
in
|
||||
List.iteri
|
||||
(fun i v ->
|
||||
Buffer.add_string f.allocas
|
||||
(Printf.sprintf
|
||||
" call void @llvm.dbg.declare(metadata ptr %s, metadata !%d, metadata !DIExpression()), !dbg !%d\n"
|
||||
f.slots.(i) v dl))
|
||||
vars;
|
||||
let sty =
|
||||
dnode d
|
||||
(Printf.sprintf "!DISubroutineType(types: !{%s})"
|
||||
(String.concat ", "
|
||||
((if is_void fn.Tast.ret then "null"
|
||||
else Printf.sprintf "!%d" (dty m d fn.Tast.ret))
|
||||
:: List.map (fun t -> Printf.sprintf "!%d" (dty m d t))
|
||||
fn.Tast.params)))
|
||||
in
|
||||
dput d sub
|
||||
(Printf.sprintf
|
||||
"distinct !DISubprogram(name: \"%s\", linkageName: \"flan.%s\", scope: !%d, file: !%d, line: %d, type: !%d, scopeLine: %d, spFlags: DISPFlagDefinition, flags: DIFlagPrototyped, unit: !%d, retainedNodes: !{%s})"
|
||||
(dstr fn.Tast.name) (dstr fn.Tast.name) file file f.dline sty f.dline
|
||||
d.dcu
|
||||
(String.concat ", " (List.map (fun v -> Printf.sprintf "!%d" v) vars)));
|
||||
at_loc f fn.Tast.floc
|
||||
| _ -> ());
|
||||
let last = ref "zeroinitializer" in
|
||||
List.iter (fun e -> last := value f e) fn.Tast.body;
|
||||
(* A Unit function's body may end on a form of any type — the value is
|
||||
@ -1102,8 +1443,9 @@ let emit_fn m ?(hidden = false) (fn : Tast.fn) =
|
||||
end
|
||||
end;
|
||||
Buffer.add_string m.out
|
||||
(Printf.sprintf "\ndefine %s%s {\nentry:\n%s%s}\n"
|
||||
(Printf.sprintf "\ndefine %s%s%s {\nentry:\n%s%s}\n"
|
||||
(if hidden then "hidden " else "") (signature ~named:true fn)
|
||||
(match dsub with None -> "" | Some n -> Printf.sprintf " !dbg !%d" n)
|
||||
(Buffer.contents f.allocas) (Buffer.contents f.b))
|
||||
|
||||
(* ── Globals ───────────────────────────────────────────────────────── *)
|
||||
@ -1217,12 +1559,39 @@ let emit_main m (fn : Tast.fn) =
|
||||
emitters look names up in, the struct types, and the foreign [declare]s.
|
||||
Both entry points below start here, so a redefinition module cannot drift
|
||||
from the whole-program one in how it names or lays out a type. *)
|
||||
let new_module ~checks ~dev ~known (p : Tast.program) =
|
||||
(* Which file the compile unit is about. Every subprogram carries its own
|
||||
[!DIFile], so this only decides what a debugger calls the unit as a whole;
|
||||
the first function anyone actually wrote is the honest answer. *)
|
||||
let cu_file (p : Tast.program) =
|
||||
match
|
||||
List.find_opt (fun (f : Tast.fn) -> f.Tast.floc.Loc.line > 0) p.Tast.fns
|
||||
with
|
||||
| Some f -> f.Tast.floc.Loc.file
|
||||
| None -> "<flan>"
|
||||
|
||||
let new_dbg (p : Tast.program) =
|
||||
let d =
|
||||
{ dn = 0; dout = Buffer.create 4096; dfiles = Hashtbl.create 8;
|
||||
dtys = Hashtbl.create 32; dlocs = Hashtbl.create 256; dcu = 0 }
|
||||
in
|
||||
let file = dfile d (cu_file p) in
|
||||
d.dcu <- dalloc d;
|
||||
(* [isOptimized: false] is not decoration: it is what a debug build is, and
|
||||
[Build] sets -O0 to make it true. DW_LANG_C99 because the layout is C's
|
||||
and lldb's C support is then exactly right for it. *)
|
||||
dput d d.dcu
|
||||
(Printf.sprintf
|
||||
"distinct !DICompileUnit(language: DW_LANG_C99, file: !%d, producer: \"flan\", isOptimized: false, runtimeVersion: 0, emissionKind: FullDebug, splitDebugInlining: false)"
|
||||
file);
|
||||
d
|
||||
|
||||
let new_module ~checks ~dev ~known ?(debug = false) (p : Tast.program) =
|
||||
let m = {
|
||||
out = Buffer.create 8192; strs = Buffer.create 512;
|
||||
structs = Hashtbl.create 16; globals = Hashtbl.create 16;
|
||||
externs = Hashtbl.create 32;
|
||||
checks; dev; known; nstr = 0;
|
||||
dbg = (if debug then Some (new_dbg p) else None);
|
||||
} in
|
||||
List.iter (fun (s : Tast.structure) -> Hashtbl.replace m.structs s.Tast.sname s)
|
||||
p.Tast.structs;
|
||||
@ -1257,12 +1626,32 @@ let new_module ~checks ~dev ~known (p : Tast.program) =
|
||||
if p.Tast.externs <> [] then Buffer.add_char m.out '\n';
|
||||
m
|
||||
|
||||
let finish m = header ^ Buffer.contents m.strs ^ "\n" ^ Buffer.contents m.out
|
||||
(* The two named metadata nodes without which none of the above survives:
|
||||
LLVM drops every scrap of debug metadata, silently and with no diagnostic,
|
||||
if "Debug Info Version" is absent. A build that "works" and shows nothing in
|
||||
the debugger is that flag. *)
|
||||
let dmodule d =
|
||||
let b = Buffer.create 512 in
|
||||
Buffer.add_string b
|
||||
"\ndeclare void @llvm.dbg.declare(metadata, metadata, metadata)\n\n";
|
||||
let dv = dalloc d and div = dalloc d in
|
||||
dput d dv "!{i32 7, !\"Dwarf Version\", i32 5}";
|
||||
dput d div "!{i32 2, !\"Debug Info Version\", i32 3}";
|
||||
Buffer.add_string b (Printf.sprintf "!llvm.dbg.cu = !{!%d}\n" d.dcu);
|
||||
Buffer.add_string b
|
||||
(Printf.sprintf "!llvm.module.flags = !{!%d, !%d}\n\n" dv div);
|
||||
Buffer.add_buffer b d.dout;
|
||||
Buffer.contents b
|
||||
|
||||
let finish m =
|
||||
header ^ Buffer.contents m.strs ^ "\n" ^ Buffer.contents m.out
|
||||
^ (match m.dbg with None -> "" | Some d -> dmodule d)
|
||||
|
||||
(* [checks] is on by default: a dev build traps on an out-of-bounds [at] or
|
||||
[slice], a release build is told to drop them. *)
|
||||
let program ?(checks = true) ?(dev = false) (p : Tast.program) : string =
|
||||
let m = new_module ~checks ~dev ~known:(fun _ -> true) p in
|
||||
let program ?(checks = true) ?(dev = false) ?(debug = false) ?(pnames = [])
|
||||
(p : Tast.program) : string =
|
||||
let m = new_module ~checks ~dev ~known:(fun _ -> true) ~debug p in
|
||||
(* One cell per function, initialised to the function this build compiled.
|
||||
Nothing has been redefined yet, so a dev build starts out behaving exactly
|
||||
like a release one — the indirection is the only difference. *)
|
||||
@ -1276,7 +1665,13 @@ let program ?(checks = true) ?(dev = false) (p : Tast.program) : string =
|
||||
Buffer.add_char m.out '\n'
|
||||
end;
|
||||
List.iter (emit_global m) p.Tast.globals;
|
||||
List.iter (emit_fn m) p.Tast.fns;
|
||||
List.iter
|
||||
(fun (fn : Tast.fn) ->
|
||||
emit_fn m
|
||||
~pnames:(match List.assoc_opt fn.Tast.name pnames with
|
||||
| Some ns -> ns | None -> [])
|
||||
fn)
|
||||
p.Tast.fns;
|
||||
(match List.find_opt (fun (f : Tast.fn) -> f.Tast.name = "main") p.Tast.fns with
|
||||
| Some fn -> emit_main m fn
|
||||
| None -> ());
|
||||
@ -1307,7 +1702,8 @@ let program ?(checks = true) ?(dev = false) (p : Tast.program) : string =
|
||||
|
||||
String literals still have to come along: they are this module's own
|
||||
constants, and omitting them is an undefined [@.str.N] at link time. *)
|
||||
let redefinition ?(checks = true) ?(dev = false) ?(known = fun _ -> true)
|
||||
let redefinition ?(checks = true) ?(dev = false) ?(debug = false)
|
||||
?(known = fun _ -> true)
|
||||
?call ?(consts = []) (p : Tast.program) ~fns : string =
|
||||
let target name =
|
||||
match List.find_opt (fun (f : Tast.fn) -> f.Tast.name = name) p.Tast.fns with
|
||||
@ -1332,7 +1728,7 @@ let redefinition ?(checks = true) ?(dev = false) ?(known = fun _ -> true)
|
||||
let siblings =
|
||||
List.filter (fun (f : Tast.fn) -> f.Tast.fparent = None) p.Tast.fns
|
||||
in
|
||||
let m = new_module ~checks ~dev ~known p in
|
||||
let m = new_module ~checks ~dev ~known ~debug p in
|
||||
(* A thunk the module runs itself is excluded from all of this: it is called
|
||||
directly by [flan_reload_call], so it needs no cell, must not be published
|
||||
into one, and must not take a registry slot — there are 4096 of those and
|
||||
|
||||
Loading…
x
Reference in New Issue
Block a user