diff --git a/lib/check.ml b/lib/check.ml index c73f8d89..ff93f8bb 100644 --- a/lib/check.ml +++ b/lib/check.ml @@ -12319,233 +12319,10 @@ let dyn_descriptors (p : Tast.program) = "What C hands back points at storage this compiler never rooted") p.Tast.externs; value_sites p (fun ~slot:_ loc what t -> check loc what t) -(* The environment struct a capture built. [Session]'s layout guard exempts - these; see there. *) -let is_env_struct n = String.length n >= 4 && String.sub n 0 4 = "env/" - -(* ── Where a closure's environment lives ─────────────────────────────── - - A capturing [fn] is checked with its copies on the frame it was written - in: a slot holding the environment struct, and a [Closure] carrying the - slot's address. That is right for a value that is only called, passed - down and let-bound — the frame outlives every use — and it costs nothing - the static side would notice. A value that may outlive the frame needs - its copies somewhere the frame's end does not reclaim, and for those this - pass rewrites the literal to carry the copies themselves; the backend - then allocates the environment from the collector. Only a closure that - escapes allocates: the static side does not pay for the dynamic side. - - **What escapes.** The analysis follows function values back to where they - came from — a literal, a parameter, or a lifted body's copy of a captured - value — and asks whether any of those reaches a position that outlives - the frame: a [set], a [return] or a function's last form, an [Option], a - fixed array, a struct or data type field, a pointer to the slot holding - it, anything handed to the runtime (a push, a put, a box), a restart's - arguments, and any argument of a call through a function value. A call - to a named function passes the question to the callee's parameter, and a - capture passes it to the lifted body's copy — or escapes outright when - the capturing literal itself escapes. Everything only grows, so the pass - runs to a fixed point over the whole program. - - A function value read out of storage — a field, an element, a case — has - no source here and needs none: nothing puts a value in storage without - going through one of the positions above, which already sent its literal - to the collector. *) -type fsrc = Lit of string | Par of int | Env of int - -(* Whether a [Closure]'s environment is a collector allocation: it carries - its copies rather than the address of a frame slot holding them. *) -let heap_env (env : Tast.expr) = - match env.Tast.ty with Types.Ptr _ -> false | _ -> true - -let place_closures (fns : Tast.fn list) : Tast.fn list = - let by_name = Hashtbl.create 64 in - List.iter (fun (f : Tast.fn) -> Hashtbl.replace by_name f.Tast.name f) fns; - let lits = Hashtbl.create 16 in (* escaping literals *) - let pars = Hashtbl.create 16 in (* (fn, i) escaping params *) - let envs = Hashtbl.create 16 in (* (fn, i) escaping copies *) - let changed = ref true in - let mark tbl k = - if not (Hashtbl.mem tbl k) then begin - Hashtbl.replace tbl k (); - changed := true - end - in - let is_fn (t : Types.t) = match t with Types.Fn _ -> true | _ -> false in - let pass (fn : Tast.fn) = - let slot = Hashtbl.create 16 in - let add s rs = - let old = try Hashtbl.find slot s with Not_found -> [] in - Hashtbl.replace slot s (List.sort_uniq compare (rs @ old)) - in - List.iteri (fun i t -> if is_fn t then add i [ Par i ]) fn.Tast.params; - (* The environment structs this function fills, by the slot they sit - in: a literal's [Closure] and a handler frame name the slot. *) - let makes = Hashtbl.create 8 in - let escape rs = - List.iter - (function - | Lit n -> mark lits n - | Par i -> mark pars (fn.Tast.name, i) - | Env i -> mark envs (fn.Tast.name, i)) - rs - in - let rec roots (e : Tast.expr) = - if not (is_fn e.Tast.ty) then [] - else - let tail body = - match List.rev body with x :: _ -> roots x | [] -> [] - in - match e.Tast.e with - | Tast.Closure (Tast.Flanfn n, _) -> [ Lit n ] - | Tast.Local s -> (try Hashtbl.find slot s with Not_found -> []) - | Tast.If (_, a, b) -> roots a @ roots b - | Tast.Do body | Tast.Let (_, body) | Tast.Handled (_, body) - | Tast.WithAlloc (_, body) -> tail body - | Tast.Match (_, arms) -> - List.concat_map (fun (a : Tast.arm) -> tail a.Tast.abody) arms - | Tast.RestartCase (cs, body) -> - roots body - @ List.concat_map (fun (c : Tast.rclause) -> tail c.Tast.rbody) cs - | _ -> [] - in - let deny es = List.iter (fun e -> escape (roots e)) es in - (* A capture: each copy escapes when the literal does, or when the - lifted body lets its copy escape. *) - let captured (fields : Tast.expr list) outright lifted = - List.iteri - (fun j (v : Tast.expr) -> - if outright || Hashtbl.mem envs (lifted, j) then escape (roots v)) - fields - in - let go (e : Tast.expr) = - match e.Tast.e with - | Tast.Let (bs, _) -> - List.iter - (fun (s, (v : Tast.expr)) -> - (match v.Tast.e with - | Tast.Make (n, es) when is_env_struct n -> Hashtbl.replace makes s es - (* A lifted body's copy of what it captured. *) - | Tast.Field - ({ Tast.e = Tast.Deref { Tast.e = Tast.Local es; _ }; _ }, i) - when fn.Tast.fenv = Some es -> add s [ Env i ] - | _ -> ()); - add s (roots v)) - bs - | Tast.Set (_, v) | Tast.Return (Some v) | Tast.Some_ v -> deny [ v ] - | Tast.Arr es | Tast.MakeCase (_, _, es) - | Tast.InvokeRestart (_, _, es, _, _, _) -> deny es - | Tast.Make (n, es) -> if not (is_env_struct n) then deny es - | Tast.Addr (Tast.Plocal s) -> - escape (try Hashtbl.find slot s with Not_found -> []) - | Tast.Prim (Tast.Rt _, es) | Tast.Prim (Tast.AddrOf, es) -> deny es - | Tast.CallPtr (_, es) -> deny es - | Tast.Call (name, es) -> - if Hashtbl.mem by_name name then - List.iteri (fun i a -> if Hashtbl.mem pars (name, i) then deny [ a ]) es - else deny es - | Tast.Closure (Tast.Flanfn n, { Tast.e = Tast.Addr (Tast.Plocal s); _ }) -> - (match Hashtbl.find_opt makes s with - | Some fields -> captured fields (Hashtbl.mem lits n) n - | None -> ()) - | Tast.Handled (hs, _) -> - List.iter - (fun (h : Tast.hframe) -> - match h.Tast.henv with - | Some { Tast.e = Tast.Addr (Tast.Plocal s); _ } -> - (match Hashtbl.find_opt makes s with - | Some fields -> captured fields false h.Tast.hfn - | None -> ()) - | _ -> ()) - hs - | _ -> () - in - (* Twice over the body: an environment struct is bound around the form - that names it, and a slot's sources are complete before a use of it - elsewhere in a loop is asked about. *) - for _ = 1 to 2 do - List.iter (Tast.walk go) fn.Tast.body; - List.iter (Tast.walk go) fn.Tast.fdefers - done; - if is_fn fn.Tast.ret then - match List.rev fn.Tast.body with x :: _ -> escape (roots x) | [] -> () - in - while !changed do - changed := false; - List.iter pass fns - done; - if Hashtbl.length lits = 0 then fns - else begin - let rec rw (e : Tast.expr) : Tast.expr = - let r = rw and rs = List.map rw in - let e' = - match e.Tast.e with - | Tast.Int _ | Tast.Float _ | Tast.Bool _ | Tast.Str _ | Tast.Unit - | Tast.Zero _ | Tast.Uninit _ | Tast.Local _ | Tast.Global _ - | Tast.None_ | Tast.FnAddr _ | Tast.Break _ | Tast.Continue _ -> e.Tast.e - | Tast.Fill (t, b) -> Tast.Fill (t, r b) - | Tast.DeadBeef (t, b) -> Tast.DeadBeef (t, r b) - | Tast.Prim (p, es) -> Tast.Prim (p, rs es) - | Tast.Call (n, es) -> Tast.Call (n, rs es) - | Tast.Do es -> Tast.Do (rs es) - | Tast.Make (n, es) -> Tast.Make (n, rs es) - | Tast.MakeCase (a, b, es) -> Tast.MakeCase (a, b, rs es) - | Tast.Arr es -> Tast.Arr (rs es) - | Tast.InvokeRestart (a, b, es, c, d, l) -> - Tast.InvokeRestart (a, b, rs es, c, d, l) - | Tast.CallPtr (c, es) -> Tast.CallPtr (r c, rs es) - (* The rewrite itself: the store of the copies into this frame and - the value carrying their address become the value carrying the - copies, which the backend stores into a collector allocation. *) - | Tast.Let - ([ (_, make) ], [ { Tast.e = Tast.Closure ((Tast.Flanfn n as fr), _); _ } ]) - when Hashtbl.mem lits n -> - Tast.Closure (fr, r make) - | Tast.Let (bs, body) -> - Tast.Let (List.map (fun (s, v) -> (s, r v)) bs, rs body) - | Tast.If (a, b, c) -> Tast.If (r a, r b, r c) - | Tast.While (c, body, latch) -> Tast.While (r c, rs body, rs latch) - | Tast.Return v -> Tast.Return (Option.map r v) - | Tast.Set (p, v) -> Tast.Set (rp p, r v) - | Tast.Addr p -> Tast.Addr (rp p) - | Tast.Field (t, i) -> Tast.Field (r t, i) - | Tast.Deref t -> Tast.Deref (r t) - | Tast.CaseField (t, c, i) -> Tast.CaseField (r t, c, i) - | Tast.Some_ t -> Tast.Some_ (r t) - | Tast.UnwrapSome t -> Tast.UnwrapSome (r t) - | Tast.Signal (k, i, t) -> Tast.Signal (k, i, r t) - | Tast.Closure (f, t) -> Tast.Closure (f, r t) - | Tast.Thicken (n, t) -> Tast.Thicken (n, r t) - | Tast.Match (sc, arms) -> - Tast.Match - (r sc, - List.map (fun (a : Tast.arm) -> { a with Tast.abody = rs a.Tast.abody }) arms) - | Tast.Handled (hs, body) -> - Tast.Handled - (List.map - (fun (h : Tast.hframe) -> { h with Tast.henv = Option.map r h.Tast.henv }) - hs, - rs body) - | Tast.RestartCase (cs, body) -> - Tast.RestartCase - (List.map (fun (c : Tast.rclause) -> { c with Tast.rbody = rs c.Tast.rbody }) cs, - r body) - | Tast.WithAlloc (a, body) -> Tast.WithAlloc (r a, rs body) - in - if e' == e.Tast.e then e else { e with Tast.e = e' } - and rp (p : Tast.place) : Tast.place = - match p with - | Tast.Plocal _ | Tast.Pglobal _ -> p - | Tast.Pfield (t, i) -> Tast.Pfield (rw t, i) - | Tast.Pderef t -> Tast.Pderef (rw t) - | Tast.Pindex (t, idx) -> Tast.Pindex (rw t, List.map rw idx) - in - List.map - (fun (f : Tast.fn) -> - { f with Tast.body = List.map rw f.Tast.body; - fdefers = List.map rw f.Tast.fdefers }) - fns - end +(* See lib/closures.ml. *) +let is_env_struct = Closures.is_env_struct +let heap_env = Closures.heap_env +let place_closures fns = Closures.place ~dev:false fns let build_program ~keep_going ?tolerate (decls : Ast.decl list) : Tast.program * env * string list = diff --git a/lib/closures.ml b/lib/closures.ml new file mode 100644 index 00000000..2042f619 --- /dev/null +++ b/lib/closures.ml @@ -0,0 +1,242 @@ +(* Where a capturing fn's environment lives: on the frame it was written in, + or on the collector's heap. A module of its own, beneath both [Check] and + the emitters, because the answer depends on the build: [Check] places + precisely, and a dev build's emitters place again under the dev rule — + see [place]. *) + +(* The environment struct a capture built. [Session]'s layout guard exempts + these; see there. *) +let is_env_struct n = String.length n >= 4 && String.sub n 0 4 = "env/" + +(* ── Where a closure's environment lives ─────────────────────────────── + + A capturing [fn] is checked with its copies on the frame it was written + in: a slot holding the environment struct, and a [Closure] carrying the + slot's address. That is right for a value that is only called, passed + down and let-bound — the frame outlives every use — and it costs nothing + the static side would notice. A value that may outlive the frame needs + its copies somewhere the frame's end does not reclaim, and for those this + pass rewrites the literal to carry the copies themselves; the backend + then allocates the environment from the collector. Only a closure that + escapes allocates: the static side does not pay for the dynamic side. + + **What escapes.** The analysis follows function values back to where they + came from — a literal, a parameter, or a lifted body's copy of a captured + value — and asks whether any of those reaches a position that outlives + the frame: a [set], a [return] or a function's last form, an [Option], a + fixed array, a struct or data type field, a pointer to the slot holding + it, anything handed to the runtime (a push, a put, a box), a restart's + arguments, and any argument of a call through a function value. A call + to a named function passes the question to the callee's parameter, and a + capture passes it to the lifted body's copy — or escapes outright when + the capturing literal itself escapes. Everything only grows, so the pass + runs to a fixed point over the whole program. + + A function value read out of storage — a field, an element, a case — has + no source here and needs none: nothing puts a value in storage without + going through one of the positions above, which already sent its literal + to the collector. *) +type fsrc = Lit of string | Par of int | Env of int + +(* Whether a [Closure]'s environment is a collector allocation: it carries + its copies rather than the address of a frame slot holding them. *) +let heap_env (env : Tast.expr) = + match env.Tast.ty with Types.Ptr _ -> false | _ -> true + +(* [dev] is a dev build's rule. There a call to a named function goes through + its cell, and a redefinition can replace the callee with a body that keeps + the value — while the caller, which is not recompiled, still made it on its + frame. So a closure handed to any named call escapes, whatever the callee + does today. A release build asks the callee. *) +let place ~dev (fns : Tast.fn list) : Tast.fn list = + let by_name = Hashtbl.create 64 in + List.iter (fun (f : Tast.fn) -> Hashtbl.replace by_name f.Tast.name f) fns; + let lits = Hashtbl.create 16 in (* escaping literals *) + let pars = Hashtbl.create 16 in (* (fn, i) escaping params *) + let envs = Hashtbl.create 16 in (* (fn, i) escaping copies *) + let changed = ref true in + let mark tbl k = + if not (Hashtbl.mem tbl k) then begin + Hashtbl.replace tbl k (); + changed := true + end + in + let is_fn (t : Types.t) = match t with Types.Fn _ -> true | _ -> false in + let pass (fn : Tast.fn) = + let slot = Hashtbl.create 16 in + let add s rs = + let old = try Hashtbl.find slot s with Not_found -> [] in + Hashtbl.replace slot s (List.sort_uniq compare (rs @ old)) + in + List.iteri (fun i t -> if is_fn t then add i [ Par i ]) fn.Tast.params; + (* The environment structs this function fills, by the slot they sit + in: a literal's [Closure] and a handler frame name the slot. *) + let makes = Hashtbl.create 8 in + let escape rs = + List.iter + (function + | Lit n -> mark lits n + | Par i -> mark pars (fn.Tast.name, i) + | Env i -> mark envs (fn.Tast.name, i)) + rs + in + let rec roots (e : Tast.expr) = + if not (is_fn e.Tast.ty) then [] + else + let tail body = + match List.rev body with x :: _ -> roots x | [] -> [] + in + match e.Tast.e with + | Tast.Closure (Tast.Flanfn n, _) -> [ Lit n ] + | Tast.Local s -> (try Hashtbl.find slot s with Not_found -> []) + | Tast.If (_, a, b) -> roots a @ roots b + | Tast.Do body | Tast.Let (_, body) | Tast.Handled (_, body) + | Tast.WithAlloc (_, body) -> tail body + | Tast.Match (_, arms) -> + List.concat_map (fun (a : Tast.arm) -> tail a.Tast.abody) arms + | Tast.RestartCase (cs, body) -> + roots body + @ List.concat_map (fun (c : Tast.rclause) -> tail c.Tast.rbody) cs + | _ -> [] + in + let deny es = List.iter (fun e -> escape (roots e)) es in + (* A capture: each copy escapes when the literal does, or when the + lifted body lets its copy escape. *) + let captured (fields : Tast.expr list) outright lifted = + List.iteri + (fun j (v : Tast.expr) -> + if outright || Hashtbl.mem envs (lifted, j) then escape (roots v)) + fields + in + let go (e : Tast.expr) = + match e.Tast.e with + | Tast.Let (bs, _) -> + List.iter + (fun (s, (v : Tast.expr)) -> + (match v.Tast.e with + | Tast.Make (n, es) when is_env_struct n -> Hashtbl.replace makes s es + (* A lifted body's copy of what it captured. *) + | Tast.Field + ({ Tast.e = Tast.Deref { Tast.e = Tast.Local es; _ }; _ }, i) + when fn.Tast.fenv = Some es -> add s [ Env i ] + | _ -> ()); + add s (roots v)) + bs + | Tast.Set (_, v) | Tast.Return (Some v) | Tast.Some_ v -> deny [ v ] + | Tast.Arr es | Tast.MakeCase (_, _, es) + | Tast.InvokeRestart (_, _, es, _, _, _) -> deny es + | Tast.Make (n, es) -> if not (is_env_struct n) then deny es + | Tast.Addr (Tast.Plocal s) -> + escape (try Hashtbl.find slot s with Not_found -> []) + | Tast.Prim (Tast.Rt _, es) | Tast.Prim (Tast.AddrOf, es) -> deny es + | Tast.CallPtr (_, es) -> deny es + | Tast.Call (name, es) -> + if Hashtbl.mem by_name name && not dev then + List.iteri (fun i a -> if Hashtbl.mem pars (name, i) then deny [ a ]) es + else deny es + | Tast.Closure (Tast.Flanfn n, { Tast.e = Tast.Addr (Tast.Plocal s); _ }) -> + (match Hashtbl.find_opt makes s with + | Some fields -> captured fields (Hashtbl.mem lits n) n + | None -> ()) + | Tast.Handled (hs, _) -> + List.iter + (fun (h : Tast.hframe) -> + match h.Tast.henv with + | Some { Tast.e = Tast.Addr (Tast.Plocal s); _ } -> + (match Hashtbl.find_opt makes s with + | Some fields -> captured fields false h.Tast.hfn + | None -> ()) + | _ -> ()) + hs + | _ -> () + in + (* Twice over the body: an environment struct is bound around the form + that names it, and a slot's sources are complete before a use of it + elsewhere in a loop is asked about. *) + for _ = 1 to 2 do + List.iter (Tast.walk go) fn.Tast.body; + List.iter (Tast.walk go) fn.Tast.fdefers + done; + if is_fn fn.Tast.ret then + match List.rev fn.Tast.body with x :: _ -> escape (roots x) | [] -> () + in + while !changed do + changed := false; + List.iter pass fns + done; + if Hashtbl.length lits = 0 then fns + else begin + let rec rw (e : Tast.expr) : Tast.expr = + let r = rw and rs = List.map rw in + let e' = + match e.Tast.e with + | Tast.Int _ | Tast.Float _ | Tast.Bool _ | Tast.Str _ | Tast.Unit + | Tast.Zero _ | Tast.Uninit _ | Tast.Local _ | Tast.Global _ + | Tast.None_ | Tast.FnAddr _ | Tast.Break _ | Tast.Continue _ -> e.Tast.e + | Tast.Fill (t, b) -> Tast.Fill (t, r b) + | Tast.DeadBeef (t, b) -> Tast.DeadBeef (t, r b) + | Tast.Prim (p, es) -> Tast.Prim (p, rs es) + | Tast.Call (n, es) -> Tast.Call (n, rs es) + | Tast.Do es -> Tast.Do (rs es) + | Tast.Make (n, es) -> Tast.Make (n, rs es) + | Tast.MakeCase (a, b, es) -> Tast.MakeCase (a, b, rs es) + | Tast.Arr es -> Tast.Arr (rs es) + | Tast.InvokeRestart (a, b, es, c, d, l) -> + Tast.InvokeRestart (a, b, rs es, c, d, l) + | Tast.CallPtr (c, es) -> Tast.CallPtr (r c, rs es) + (* The rewrite itself: the store of the copies into this frame and + the value carrying their address become the value carrying the + copies, which the backend stores into a collector allocation. *) + | Tast.Let + ([ (_, make) ], [ { Tast.e = Tast.Closure ((Tast.Flanfn n as fr), _); _ } ]) + when Hashtbl.mem lits n -> + Tast.Closure (fr, r make) + | Tast.Let (bs, body) -> + Tast.Let (List.map (fun (s, v) -> (s, r v)) bs, rs body) + | Tast.If (a, b, c) -> Tast.If (r a, r b, r c) + | Tast.While (c, body, latch) -> Tast.While (r c, rs body, rs latch) + | Tast.Return v -> Tast.Return (Option.map r v) + | Tast.Set (p, v) -> Tast.Set (rp p, r v) + | Tast.Addr p -> Tast.Addr (rp p) + | Tast.Field (t, i) -> Tast.Field (r t, i) + | Tast.Deref t -> Tast.Deref (r t) + | Tast.CaseField (t, c, i) -> Tast.CaseField (r t, c, i) + | Tast.Some_ t -> Tast.Some_ (r t) + | Tast.UnwrapSome t -> Tast.UnwrapSome (r t) + | Tast.Signal (k, i, t) -> Tast.Signal (k, i, r t) + | Tast.Closure (f, t) -> Tast.Closure (f, r t) + | Tast.Thicken (n, t) -> Tast.Thicken (n, r t) + | Tast.Match (sc, arms) -> + Tast.Match + (r sc, + List.map (fun (a : Tast.arm) -> { a with Tast.abody = rs a.Tast.abody }) arms) + | Tast.Handled (hs, body) -> + Tast.Handled + (List.map + (fun (h : Tast.hframe) -> { h with Tast.henv = Option.map r h.Tast.henv }) + hs, + rs body) + | Tast.RestartCase (cs, body) -> + Tast.RestartCase + (List.map (fun (c : Tast.rclause) -> { c with Tast.rbody = rs c.Tast.rbody }) cs, + r body) + | Tast.WithAlloc (a, body) -> Tast.WithAlloc (r a, rs body) + in + if e' == e.Tast.e then e else { e with Tast.e = e' } + and rp (p : Tast.place) : Tast.place = + match p with + | Tast.Plocal _ | Tast.Pglobal _ -> p + | Tast.Pfield (t, i) -> Tast.Pfield (rw t, i) + | Tast.Pderef t -> Tast.Pderef (rw t) + | Tast.Pindex (t, idx) -> Tast.Pindex (rw t, List.map rw idx) + in + List.map + (fun (f : Tast.fn) -> + { f with Tast.body = List.map rw f.Tast.body; + fdefers = List.map rw f.Tast.fdefers }) + fns + end + + +let dev_program (p : Tast.program) = + { p with Tast.fns = place ~dev:true p.Tast.fns } diff --git a/lib/emit.ml b/lib/emit.ml index 02683212..0e27575b 100644 --- a/lib/emit.ml +++ b/lib/emit.ml @@ -5417,6 +5417,10 @@ let macro_thunk m (fn : Tast.fn) = let program ?(checks = true) ?(dev = false) ?(debug = false) ?(pnames = []) ?(sanitize = false) ?(macros = []) ?(hidden = false) ?(annotate = false) (p : Tast.program) : string = + (* A dev build places closures under the dev rule: a named callee can be + replaced by a redefinition that keeps what it was handed. See + [Closures.place]. *) + let p = if dev then Closures.dev_program p else p in (* [hidden] and [dev] are opposites and the refusal is here so that they cannot be written together by accident. A dev build's whole point is that its cells, its globals and [flan.abi.*] are in the dynamic symbol table @@ -5567,6 +5571,10 @@ let redefinition ?(checks = true) ?(dev = false) ?(debug = false) ?(known = fun _ -> true) ?(retains = true) ?call ?(consts = []) ?(annotate = false) (p : Tast.program) ~fns : string = + (* A dev build places closures under the dev rule: a named callee can be + replaced by a redefinition that keeps what it was handed. See + [Closures.place]. *) + let p = if dev then Closures.dev_program p else p in let target name = match List.find_opt (fun (f : Tast.fn) -> f.Tast.name = name) p.Tast.fns with | Some f -> f diff --git a/lib/x86.ml b/lib/x86.ml index dd8f7baf..de4665cf 100644 --- a/lib/x86.ml +++ b/lib/x86.ml @@ -4873,6 +4873,10 @@ let emit_dwarf (dw : dwarf) ~cufile ~tbeg ~tend = (* A whole program as one assembly file. *) let program ~checks ?(dev = false) ?(debug = false) ?(annotate = false) (p : Tast.program) : string = + (* A dev build places closures under the dev rule: a named callee can be + replaced by a redefinition that keeps what it was handed. See + [Closures.place]. *) + let p = if dev then Closures.dev_program p else p in let md = layout_ctx ~checks ~dev p in let externs = Hashtbl.create 16 in List.iter @@ -5163,6 +5167,10 @@ let program ~checks ?(dev = false) ?(debug = false) ?(annotate = false) let redefinition ~checks ?(dev = true) ?(known = fun _ -> true) ?(retains = true) ?(consts = []) ?call ?(annotate = false) (p : Tast.program) ~fns : string = + (* A dev build places closures under the dev rule: a named callee can be + replaced by a redefinition that keeps what it was handed. See + [Closures.place]. *) + let p = if dev then Closures.dev_program p else p in if not dev then unsupported "x86 redefinition without cells: there is nothing to publish a body \ diff --git a/test/programs/fn-dev-escape.flan b/test/programs/fn-dev-escape.flan new file mode 100644 index 00000000..32b15ab1 --- /dev/null +++ b/test/programs/fn-dev-escape.flan @@ -0,0 +1,8 @@ +;; [store] only calls what it is handed, so in a release build [go]'s closure +;; stays on go's frame. In a dev build [store] can be redefined to keep it — +;; (set kept (Some f)) — and only [store] is recompiled, so [go] must already +;; have made its closure on the collector's heap. +(defonce kept (Option (Fn [i64] i64))) +(defn store [f (Fn [i64] i64)] () (println (f 0))) +(defn go [n i64] () (store (fn [x] (+ x n)))) +(defn main [] i32 (go 5) 0) diff --git a/test/test_acceptance.ml b/test/test_acceptance.ml index 938b6bb1..19deffc0 100644 --- a/test/test_acceptance.ml +++ b/test/test_acceptance.ml @@ -5376,6 +5376,49 @@ level "1" (* A capturing fn allocates its environment from the collector, so it is a site too, with its own sentence. The file has more than one. *) no_gc_sites "programs/fn-escape.flan" 2; + (* A dev build cannot trust what a named callee does with a closure: a + redefinition of the callee recompiles the callee alone. So [go]'s + closure is on the heap in both dev backends and on the frame in a + release build. The text between go's entry and the next function is + asked, which is enough to tell the two apart. *) + (let path = "programs/fn-dev-escape.flan" in + let l = Load.program ~file:path (Reader.read_file path) in + let p = Check.program_all l.Load.decls in + (* From go's entry to the end of its body. *) + let go_part key text = + let n = String.length text and k = String.length key in + let rec find i = + if i + k > n then None + else if String.sub text i k = key then Some i else find (i + 1) + in + match find 0 with + | None -> "" + | Some i -> + let rest = String.sub text i (n - i) in + let m = String.length rest in + let rec close j = + if j + 2 > m then m + else if rest.[j] = '\n' && rest.[j + 1] = '}' then j + else close (j + 1) + in + if key.[0] = 'd' then String.sub rest 0 (close 0) + else String.sub rest 0 (min 4000 m) + in + let heap_ll text = contains (go_part "define {} @\"flan.go\"" text) "flan_dyn_env_new" in + let heap_x86 text = contains (go_part "\"flan.go\":" text) "flan_dyn_env_new" in + if heap_ll (Emit.program ~dev:false p) then begin + incr failures; + print_endline "FAIL a release build moved a frame closure to the heap" + end; + if not (heap_ll (Emit.program ~dev:true p)) then begin + incr failures; + print_endline "FAIL a dev build left a closure handed to a named call on the frame" + end; + if not (heap_x86 (X86.program ~checks:true ~dev:true p)) then begin + incr failures; + print_endline + "FAIL a dev --x86 build left a closure handed to a named call on the frame" + end); (* In a program that does make a collector-owned environment, a function whose only function value is a parameter still roots nothing: the caller holds what it passed. This is what keeps the prelude's