An x86 redefinition emitter, and GOT addressing for the host's symbols

This commit is contained in:
Joseph Ferano 2026-09-13 22:38:48 +07:00
parent dd5eac2821
commit 69ea66deca
2 changed files with 269 additions and 16 deletions

View File

@ -911,6 +911,48 @@ let shared ?(opts = default) ~ir ~out () : timing =
end;
{ llc_ms; link_ms }
(* The same, from the dev backend. [X86.redefinition] hands out assembly rather
than IR, so [llc] is replaced by the assembler and the link is identical --
a shared object with undefined symbols, which the loader binds back to the
host.
There is no [-relocation-model=pic] to ask for, because the emitter decides
that itself: every reference to a symbol the module does not define is
already written through the GOT. [as] is not given [-fPIC] either; the flag
does not exist for it.
An [--x86] host must get [--x86] modules. The two backends' conventions
agree on scalars and disagree on every aggregate, so crossing them is
correct exactly until the first redefined function takes or returns a
struct. See [lib/x86.ml]'s header. *)
let assembler = try Sys.getenv "FLAN_AS" with Not_found -> "as"
let shared_x86 ?(opts = default) ~asm ~out () : timing =
let dir = workdir () in
let base = Filename.remove_extension (Filename.basename out) in
let src = Filename.concat dir (base ^ ".s") in
let obj = Filename.concat dir (base ^ ".o") in
write src asm;
let (), llc_ms =
time (fun () ->
run assembler
(String.concat " "
[ Filename.quote assembler; Filename.quote src; "-o";
Filename.quote obj ]))
in
let (), link_ms =
time (fun () ->
run linker
(String.concat " "
[ Filename.quote linker; "-shared"; Filename.quote obj; "-o";
Filename.quote out ]))
in
if not opts.keep then begin
(try Sys.remove src with Sys_error _ -> ());
(try Sys.remove obj with Sys_error _ -> ())
end;
{ llc_ms; link_ms }
(* ── The macro path: a whole program into a shared object ───────────── *)
(* A macro module is not a redefinition, and the difference is the whole

View File

@ -175,21 +175,43 @@ let modrm_rip b ~r ~sym ~addend =
(if addend = 0 then "" else Printf.sprintf "+%d" addend))
4
(* The same field, against a symbol this object does not define. A [PC32]
relocation against an undefined symbol cannot be used in a shared object --
[ld] refuses the link outright -- so the address is read out of the GOT
instead and the loader binds the slot to whatever the host has.
[@GOTPCREL] is already pc-relative, so the [- .] the plain form needs is
wrong here: written with it, [as] produces an addend of -8 and the load
reads the wrong slot. [-4] alone is what [llc -relocation-model=pic]
produces for the same instruction, checked against it. There is no addend
either: the GOT holds the symbol's address and nothing else, so a field
offset is added after the load, which is what [Lgot] below does. *)
let modrm_got b ~r ~sym =
u8 b (((r land 7) lsl 3) lor 5);
dir b (Printf.sprintf ".long %s@GOTPCREL - 4" sym) 4
(* ── Instructions ────────────────────────────────────────────────────── *)
type mem = Frame of int | Reg of int * int | Sym of string * int
type mem =
| Frame of int
| Reg of int * int
| Sym of string * int
| Got of string (* the GOT slot holding [sym]'s address *)
let mem_op b ~r ~op ~(w : bool) ~(pfx : int list) ~(mm : mem) =
let base = match mm with Frame _ -> rbp | Reg (g, _) -> g | Sym _ -> 0 in
let base =
match mm with Frame _ -> rbp | Reg (g, _) -> g | Sym _ | Got _ -> 0
in
List.iter (u8 b) pfx;
(match mm with
| Sym _ -> rex b ~w ~r ~x:0 ~m:0
| Sym _ | Got _ -> rex b ~w ~r ~x:0 ~m:0
| _ -> rex b ~w ~r ~x:0 ~m:base);
List.iter (u8 b) op;
match mm with
| Frame d -> modrm_m b ~r ~base:rbp ~disp:d
| Reg (g, d) -> modrm_m b ~r ~base:g ~disp:d
| Sym (s, a) -> modrm_rip b ~r ~sym:s ~addend:a
| Got s -> modrm_got b ~r ~sym:s
let mov_rr b ~dst ~src = rex b ~w:true ~r:src ~x:0 ~m:dst; u8 b 0x89; modrm_r b ~r:src ~m:dst
@ -222,13 +244,16 @@ let store_int b ~src ~mm ~size =
| 2 -> mem_op b ~r:src ~op:[ 0x89 ] ~w:false ~pfx:[ 0x66 ] ~mm
| 1 ->
(* The one place a REX byte is needed for its own sake. *)
let base = match mm with Frame _ -> rbp | Reg (g, _) -> g | Sym _ -> 0 in
let base =
match mm with Frame _ -> rbp | Reg (g, _) -> g | Sym _ | Got _ -> 0
in
rex ~force:(src >= 4) b ~w:false ~r:src ~x:0 ~m:base;
u8 b 0x88;
(match mm with
| Frame d -> modrm_m b ~r:src ~base:rbp ~disp:d
| Reg (g, d) -> modrm_m b ~r:src ~base:g ~disp:d
| Sym (s, a) -> modrm_rip b ~r:src ~sym:s ~addend:a)
| Sym (s, a) -> modrm_rip b ~r:src ~sym:s ~addend:a
| Got s -> modrm_got b ~r:src ~sym:s)
| n -> unsupported "integer store of %d bytes" n
let alu_rr b ~op ~dst ~src =
@ -420,6 +445,12 @@ type fnctx = {
rodata : Buffer.t;
externs : (string, string) Hashtbl.t;
fns : (string, unit) Hashtbl.t;
(* True of a symbol this object does not define. Always false for a whole
program, which defines everything it names bar the runtime, and where
every reference is therefore pc-relative exactly as before. A redefinition
module answers true for the host's cells, globals and bodies, and those
go through the GOT -- see [modrm_got]. *)
ext : string -> bool;
}
(* Module-wide rather than per-function. Two functions each holding an [if]
@ -543,12 +574,14 @@ let float_const f (x : float) ~f64 =
type loc =
| Lf of int (* rbp + d *)
| Lg of string * int (* rip-relative symbol + d *)
| Lgot of string * int (* a symbol this object does not define; + d *)
| Lp of int * int (* [rbp + p] is a pointer; + d *)
let shift l d =
match l with
| Lf o -> Lf (o + d)
| Lg (s, a) -> Lg (s, a + d)
| Lgot (s, a) -> Lgot (s, a + d)
| Lp (p, a) -> Lp (p, a + d)
(* [scratch] is only touched by the [Lp] case, and every caller passes r11 —
@ -557,6 +590,12 @@ let lmem f (l : loc) ~scratch : mem =
match l with
| Lf o -> Frame o
| Lg (s, a) -> Sym (s, a)
(* The GOT slot holds the address, so this is one load more than [Lg] and
exactly the [Lp] shape afterwards -- the displacement is arithmetic on a
register base, never on the relocation. *)
| Lgot (s, a) ->
load_int f.b ~dst:scratch ~mm:(Got s) ~size:8 ~signed:false;
Reg (scratch, a)
| Lp (p, a) ->
load_int f.b ~dst:scratch ~mm:(Frame p) ~size:8 ~signed:false;
Reg (scratch, a)
@ -565,10 +604,24 @@ let addr_into f ~reg (l : loc) =
match l with
| Lf o -> lea f.b ~dst:reg ~mm:(Frame o)
| Lg (s, a) -> lea f.b ~dst:reg ~mm:(Sym (s, a))
| Lgot (s, a) ->
load_int f.b ~dst:reg ~mm:(Got s) ~size:8 ~signed:false;
if a <> 0 then add_imm f.b ~dst:reg a
| Lp (p, a) ->
load_int f.b ~dst:reg ~mm:(Frame p) ~size:8 ~signed:false;
if a <> 0 then add_imm f.b ~dst:reg a
(* The three spellings of "name a symbol", each picking the pc-relative form
for a symbol this object defines and the GOT form for one it does not. *)
let sym_mem f s = if f.ext s then Got s else Sym (s, 0)
let sym_loc f s = if f.ext s then Lgot (s, 0) else Lg (s, 0)
(* [lea] of a symbol is an address; out of the GOT the address is already
there, so the [lea] becomes a load. *)
let addr_sym f ~dst s =
if f.ext s then load_int f.b ~dst ~mm:(Got s) ~size:8 ~signed:false
else lea f.b ~dst ~mm:(Sym (s, 0))
let scalar_size f (t : Types.t) =
match t with Types.Bool -> 1 | _ -> max 1 (sizeof f.md t)
@ -941,7 +994,7 @@ and lower_at f (e : Tast.expr) (dst : loc) : unit =
link-time constant, and this is the spelling a lifted handler clause is
reached by. [emit.ml] says the same of [Flanfn]. *)
| Tast.FnAddr (Tast.Flanfn n) ->
lea f.b ~dst:rax ~mm:(Sym (fsym n, 0));
addr_sym f ~dst:rax (fsym n);
store_int f.b ~src:rax ~mm:(lmem f dst ~scratch:r11) ~size:8
(* A function value someone wrote, which is the one [FnAddr] that is not the
symbol. In a release build there is nothing to redefine and it is the
@ -952,11 +1005,11 @@ and lower_at f (e : Tast.expr) (dst : loc) : unit =
address is in a slot there is nothing left to re-resolve. *)
| Tast.FnAddr (Tast.Fnval n) ->
if f.md.Emit.dev then
load_int f.b ~dst:rax ~mm:(Sym (csym n, 0)) ~size:8 ~signed:false
else lea f.b ~dst:rax ~mm:(Sym (fsym n, 0));
load_int f.b ~dst:rax ~mm:(sym_mem f (csym n)) ~size:8 ~signed:false
else addr_sym f ~dst:rax (fsym n);
store_int f.b ~src:rax ~mm:(lmem f dst ~scratch:r11) ~size:8
| Tast.FnAddr (Tast.Rtfn n) ->
lea f.b ~dst:rax ~mm:(Sym (n, 0));
addr_sym f ~dst:rax n;
store_int f.b ~src:rax ~mm:(lmem f dst ~scratch:r11) ~size:8
| Tast.Prim (p, args) -> prim f e p args dst
| Tast.Call (name, args) ->
@ -1154,7 +1207,7 @@ and emit_handled f frames body dst t =
(* The clause's body address, deliberately, and not a cell load: a
handler frame is not a redefinable top-level value nothing can
name it and it lives only for this body. *)
lea f.b ~dst:rax ~mm:(Sym (fsym h.Tast.hfn, 0));
addr_sym f ~dst:rax (fsym h.Tast.hfn);
store_int f.b ~src:rax ~mm:(Frame (slot + h_fn)) ~size:8;
lea f.b ~dst:rdi ~mm:(Frame slot);
xor_rr f.b ~dst:rax ~src:rax;
@ -1460,7 +1513,7 @@ and block f body dst t =
and lvalue f (e : Tast.expr) : loc =
match e.Tast.e with
| Tast.Local i -> Lf f.slots.(i)
| Tast.Global n -> Lg (gsym n, 0)
| Tast.Global n -> sym_loc f (gsym n)
| Tast.Deref x -> let p = eval f x in Lp (off_of p, 0)
| Tast.Field (x, i) -> field_loc f (lvalue f x) x.Tast.ty i
(* [(at a i)] denotes a location, and the source writes through it:
@ -1571,7 +1624,7 @@ and off_of (l : loc) =
and place f (p : Tast.place) : loc =
match p with
| Tast.Plocal i -> Lf f.slots.(i)
| Tast.Pglobal n -> Lg (gsym n, 0)
| Tast.Pglobal n -> sym_loc f (gsym n)
| Tast.Pderef x -> let q = eval f x in Lp (off_of q, 0)
| Tast.Pfield (x, i) -> field_loc f (lvalue f x) x.Tast.ty i
(* [(at grid r c)] is one node with two indices, not two nodes: an array of
@ -1763,7 +1816,7 @@ and call_flan f ~target ~args ~rty dst =
(match callee with
| `Sym s -> call_sym f.b s
| `Cell s ->
load_int f.b ~dst:r11 ~mm:(Sym (s, 0)) ~size:8 ~signed:false;
load_int f.b ~dst:r11 ~mm:(sym_mem f s) ~size:8 ~signed:false;
call_r f.b r11
| `Loc o ->
load_int f.b ~dst:r11 ~mm:(Frame o) ~size:8 ~signed:false;
@ -2129,7 +2182,8 @@ let incoming_of ~sret (params : Types.t list) =
in
sret_at, ps, next_int ()
let emit_fn (md : Emit.m) ~externs ~fns (fn : Tast.fn) : string * string =
let emit_fn (md : Emit.m) ~externs ~fns ?(ext = fun _ -> false)
?(hidden = false) (fn : Tast.fn) : string * string =
let b = create () in
let nslots = Array.length fn.Tast.slots in
let f =
@ -2138,7 +2192,7 @@ let emit_fn (md : Emit.m) ~externs ~fns (fn : Tast.fn) : string * string =
xfer_off = 0; sret_off = 0; retval = 0;
frame = 0; maxframe = 0; outgoing = 0;
loops = []; pads = []; xfer_lbl = ""; unwound = false;
rodata = Buffer.create 64; externs; fns }
rodata = Buffer.create 64; externs; fns; ext }
in
(* The header's own frame model: every slot and every temporary is
bump-allocated below rbp, and the high-water mark is what the prologue
@ -2309,6 +2363,13 @@ let emit_fn (md : Emit.m) ~externs ~fns (fn : Tast.fn) : string * string =
let sym = fsym fn.Tast.name in
let out = Buffer.create 1024 in
Buffer.add_string out (Printf.sprintf "\t.globl\t%s\n" sym);
(* [emit.ml:2072] says this is load-bearing and it is: default visibility in
a shared object is interposable, and that applies to taking the address
too, so a plain reference from inside a redefinition module would resolve
to the *host's* copy and the module would install the very body it is
replacing. Only a module's own bodies are hidden; a whole program emits
none. *)
if hidden then Buffer.add_string out (Printf.sprintf "\t.hidden\t%s\n" sym);
Buffer.add_string out (Printf.sprintf "\t.type\t%s, @function\n" sym);
Buffer.add_string out (sym ^ ":\n");
Buffer.add_string out (Buffer.contents pb.out);
@ -2391,7 +2452,7 @@ let emit_globals_init (md : Emit.m) ~externs ~fns (globals : Tast.global list) =
fret = Types.Unit; slots = [||]; xfer_off = 0; sret_off = 0; retval = 0;
frame = 0; maxframe = 0; outgoing = 0; loops = []; pads = [];
xfer_lbl = ""; unwound = false;
rodata = Buffer.create 64; externs; fns }
rodata = Buffer.create 64; externs; fns; ext = (fun _ -> false) }
in
(* Two slots, not one: [xfer_off] holds the *pointer* every call passes on,
and [cell] is what it points at. Storing a null into [xfer_off] itself
@ -2569,3 +2630,153 @@ let program ~checks ?(dev = false) (p : Tast.program) : string =
Buffer.add_buffer out rodata;
Buffer.add_string out "\n\t.section\t.note.GNU-stack,\"\",@progbits\n";
Buffer.contents out
(* -- One function into a loadable object ------------------------------ *)
(* The counterpart to [Emit.redefinition], and the reason this backend exists.
[program] above emits an executable; this emits the assembly for a [.so]
that gets dlopened into a host which is {e already running}, replacing the
body behind one or more names without restarting anything.
{b Why it cannot be [Emit.redefinition].} This file licenses its own calling
convention on the grounds that a dev build is compiled entirely here and a
release build entirely by LLVM, so the two never meet in one process. The
conventions agree on every scalar and disagree on every aggregate -- here
each goes by pointer with a hidden [sret]; LLVM classifies by eightbyte. An
[Emit.redefinition] module dlopened into an [--x86] host is therefore correct
exactly until the first redefined function takes or returns a struct. The
answer is a redefinition emitter here, not an aggregate classifier there.
{b What it does not define}, each of which [program] does and each of which
would be wrong in a module:
- no [main]: this object is loaded, not started.
- no [.init_array] and in particular no [flan..init-globals]. Re-running a
global's initialiser would wipe the live state that reloading exists to
preserve -- sand's grid is a global and "edit the code, keep the sand" is
the whole demo.
- no [flan_dev_reg_enable] constructor: the host armed the registry when it
started.
- no [.bss] for the globals and no [.data] for the cells. Both are the
host's objects; this module names them and the loader binds them.
{b And what it must.} Every body is [.hidden] -- [emit.ml] says the same and
for the same reason, that default visibility in a shared object is
interposable. And [flan_reload_install], a named function rather than a
constructor, because the agent has to choose {e when} the swap happens: at a
frame boundary, on the game thread. [reload_host.c] and
[vendor/agent/flan_agent.c] both [dlsym] exactly that spelling.
{b The scope, and it is narrower than [Emit.redefinition]'s.} Only names the
host already has. A name introduced since has no symbol to bind to, and
[Emit.redefinition] answers that with [flan_dev_cell] / [flan_dev_global] and
[Emit.cellptr]'s deeper spelling -- a module-local slot resolved by string at
install time. That is not built here, and neither is the [consts] republish
nor the transient [flan_reload_call] thunk. Each is refused by name, which is
this file's idiom for a case it has not earned the right to compile. *)
let redefinition ~checks ?(dev = true) ?(known = fun _ -> true)
?(consts = []) ?call (p : Tast.program) ~fns : string =
if not dev then
unsupported
"x86 redefinition without cells: there is nothing to publish a body \
into, and this backend's release build has no indirection";
if consts <> [] then
unsupported "x86 redefinition: republishing a defconst is not built yet";
(match call with
| Some _ ->
unsupported
"x86 redefinition: the transient flan_reload_call thunk is not built yet"
| None -> ());
let target name =
match List.find_opt (fun (f : Tast.fn) -> f.Tast.name = name) p.Tast.fns with
| Some f -> f
| None -> unsupported "no such function: %s" name
in
let targets = List.map target fns in
(* A clause lifted out of a target comes with it: its body may have changed
too, and it is reached by address from inside this module rather than
through a cell. Every other lifted clause is invisible here. *)
let lifted =
List.filter
(fun (f : Tast.fn) ->
match f.Tast.fparent with
| Some q -> List.mem q fns
| None -> false)
p.Tast.fns
in
let siblings =
List.filter (fun (f : Tast.fn) -> f.Tast.fparent = None) p.Tast.fns
in
List.iter
(fun (f : Tast.fn) ->
if not (known f.Tast.name) then
unsupported
"x86 redefinition: %s is new to this session, and a name the host \
was not built with needs the flan_dev_cell lookup and \
Emit.cellptr's second spelling, which are not built here yet"
f.Tast.name)
siblings;
List.iter
(fun (g : Tast.global) ->
if not (known g.Tast.gname) then
unsupported
"x86 redefinition: the global %s is new to this session, and a new \
global needs the flan_dev_global lookup, which is not built here \
yet"
g.Tast.gname)
p.Tast.globals;
let md = layout_ctx ~checks ~dev p in
let externs = Hashtbl.create 16 in
List.iter
(fun (e : Tast.extern) -> Hashtbl.replace externs e.Tast.ename e.Tast.esym)
p.Tast.externs;
let fnstbl = Hashtbl.create 64 in
List.iter (fun (fn : Tast.fn) -> Hashtbl.replace fnstbl fn.Tast.name ())
p.Tast.fns;
(* Which symbols this object defines. Everything else -- the host's cells,
its globals, its other bodies, and every runtime entry point -- is reached
through the GOT, because a pc-relative relocation against an undefined
symbol cannot be used in a shared object at all. *)
let mine = Hashtbl.create 16 in
List.iter (fun (f : Tast.fn) -> Hashtbl.replace mine (fsym f.Tast.name) ())
(targets @ lifted);
let ext s = not (Hashtbl.mem mine s) in
let text = Buffer.create 8192 and rodata = Buffer.create 1024 in
Buffer.add_string text
"# Generated by flan's x86-64 backend: one or more functions, recompiled\n\
# into an object a running process can dlopen. Every symbol this file\n\
# does not define is the host's, and is reached through the GOT.\n\
\t.text\n\n";
List.iter
(fun (f : Tast.fn) ->
let t, r = emit_fn md ~externs ~fns:fnstbl ~ext ~hidden:true f in
Buffer.add_string text t;
Buffer.add_string rodata r)
(lifted @ targets);
(* Publishing: one store per target, and the cell's address has to be read
out of the GOT first because the cell itself lives in the host. The body
is this module's own and hidden, so its address is an ordinary
pc-relative [lea]. *)
let b = create () in
List.iter
(fun (f : Tast.fn) ->
load_int b ~dst:rax ~mm:(Got (csym f.Tast.name)) ~size:8 ~signed:false;
lea b ~dst:r11 ~mm:(Sym (fsym f.Tast.name, 0));
store_int b ~src:r11 ~mm:(Reg (rax, 0)) ~size:8)
targets;
ret b;
flush b;
Buffer.add_string text
"\t.globl\tflan_reload_install\n\
\t.type\tflan_reload_install, @function\n\
flan_reload_install:\n";
Buffer.add_buffer text b.out;
Buffer.add_string text
"\t.size\tflan_reload_install, . - flan_reload_install\n\n";
let out = Buffer.create 8192 in
Buffer.add_buffer out text;
Buffer.add_string out "\n\t.section\t.rodata\n";
Buffer.add_buffer out rodata;
Buffer.add_string out "\n\t.section\t.note.GNU-stack,\"\",@progbits\n";
Buffer.contents out