From 69ea66decae92440ec9fbbe535244e3ca612a0bd Mon Sep 17 00:00:00 2001 From: Joseph Ferano Date: Sun, 13 Sep 2026 22:38:48 +0700 Subject: [PATCH] An x86 redefinition emitter, and GOT addressing for the host's symbols --- lib/build.ml | 42 +++++++++ lib/x86.ml | 243 +++++++++++++++++++++++++++++++++++++++++++++++---- 2 files changed, 269 insertions(+), 16 deletions(-) diff --git a/lib/build.ml b/lib/build.ml index bdde411..e4f62ac 100644 --- a/lib/build.ml +++ b/lib/build.ml @@ -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 diff --git a/lib/x86.ml b/lib/x86.ml index 1e264fe..904bfe3 100644 --- a/lib/x86.ml +++ b/lib/x86.ml @@ -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