From a6ccce0e6741a42c0da4695a8fc192355a52b164 Mon Sep 17 00:00:00 2001 From: Joseph Ferano Date: Fri, 25 Sep 2026 20:50:17 +0700 Subject: [PATCH] Every store of a frame address into a global outside main is refused, fn and handler bodies and restart clauses are checked as frames of their own, and the suggested clone keeps the slice's bounds --- lib/check.ml | 427 ++++++++++++++++++++++++++-------------------- test/test_flan.ml | 32 +++- 2 files changed, 270 insertions(+), 189 deletions(-) diff --git a/lib/check.ml b/lib/check.ml index 3103436c..10d65729 100644 --- a/lib/check.ml +++ b/lib/check.ml @@ -3084,6 +3084,240 @@ let view_not_permanent loc (container : Types.t) = the other" (Types.to_string container) (Types.to_string container) +(* A value handed out of [f] that points into [f]'s own frame: returned (the + last form's tails, or a [return]), or stored into a global or a field or + array element of one. Both read a dead frame the moment [f] returns, so + both are refused. + + Deliberately narrow — the exact spellings that can only be wrong, so + nothing that could be valid is ever refused: + - [(addr p)] where [p] is a local, a field of one, or an element of a + local *array* (an array's elements are the frame's bytes; a Vec's or a + slice's are not); + - [(slice a …)] where [a] is such a place of array type; + - a local bound by [let] to one of those and never assigned or addressed + afterwards, which is also how a [return] under a [defer] arrives here. + A parameter is a local: its value is copied into the frame (an array + parameter too), so its address dies with the frame as well. Anything + reached through a [Ptr] is not the frame's, and a struct literal holding + such an address is not looked into. + + The store is let through in [main], whose frame outlives everything the + program runs. + + A lifted [fn] literal or handler clause is checked as a function of its + own: its parameters, its locals and its copies of what it captured are its + frame. What this does not see is the enclosing function's frame escaping + *through* one — a closure over a pointer to a local, handed out — because + that is a value holding an address, not one of the spellings above. *) +let refuse_frame_escapes (f : Tast.fn) = + (* Keyed by slot alone: [fresh_slot] never reuses one, so a slot has at + most one binding [Let] in the function. *) + let binds = Hashtbl.create 16 in + let unstable = Hashtbl.create 16 in + let rec place_global = function + | Tast.Pglobal g -> Some g + | Tast.Pfield (t, _) -> expr_global t + | Tast.Pindex (t, idx) when all_array t.Tast.ty idx -> expr_global t + | _ -> None + and expr_global (e : Tast.expr) = + match e.Tast.e with + | Tast.Global g -> Some g + | Tast.Field (t, _) -> expr_global t + | Tast.Prim (Tast.At, t :: idx) when all_array t.Tast.ty idx -> expr_global t + | _ -> None + (* [(at a i j)] is one node carrying every index; each level stepped must + be an array for the element to be inside [a]'s own bytes. *) + and all_array ty = function + | [] -> true + | _ :: rest -> + (match ty with Types.Array (_, el) -> all_array el rest | _ -> false) + in + List.iter + (Tast.walk (fun (e : Tast.expr) -> + match e.Tast.e with + | Tast.Let (bs, _) -> List.iter (fun (s, v) -> Hashtbl.replace binds s v) bs + | Tast.Set (Tast.Plocal s, _) | Tast.Addr (Tast.Plocal s) -> + Hashtbl.replace unstable s () + | _ -> ())) + f.Tast.body; + (* The local at the root of a place inside this frame, if it is one. *) + let rec root_expr (e : Tast.expr) = + match e.Tast.e with + | Tast.Local s -> Some s + | Tast.Field (t, _) -> root_expr t + | Tast.Prim (Tast.At, t :: idx) when all_array t.Tast.ty idx -> root_expr t + | _ -> None + in + let root_place = function + | Tast.Plocal s -> Some s + | Tast.Pfield (t, _) -> root_expr t + | Tast.Pindex (t, idx) when all_array t.Tast.ty idx -> root_expr t + | _ -> None + in + (* What escapes: the root local, whether it is a slice (else an address), + and whether the place is the bare local rather than a path into it — + only then can the fix be spelled with its name alone. *) + let rec escapes depth (e : Tast.expr) = + match e.Tast.e with + | Tast.Addr p -> + Option.map + (fun s -> + (e, (s, `Addr, (match p with Tast.Plocal _ -> true | _ -> false)))) + (root_place p) + | Tast.Prim (Tast.Slice, [ t; _; _ ]) -> + (match t.Tast.ty with + | Types.Array _ -> + Option.map + (fun s -> + ( e, + (s, `Slice, + (match t.Tast.e with Tast.Local _ -> true | _ -> false)) )) + (root_expr t) + | _ -> None) + | Tast.Local s when depth < 32 && not (Hashtbl.mem unstable s) -> + Option.bind (Hashtbl.find_opt binds s) (escapes (depth + 1)) + | _ -> None + in + (* A slot with no name is a value the function made for itself, such as + the array a literal like [(slice [7 8 9])] is stored in. *) + (* What a lifted body is called in a message: its symbol is the compiler's. *) + let who = + let starts p = + String.length f.Tast.name >= String.length p + && String.sub f.Tast.name 0 (String.length p) = p + in + if starts "fn/" then "this fn" + else if starts "handler/" then "this handler" + else f.Tast.name + in + let what (s, kind, exact) = + match f.Tast.snames.(s), kind, exact with + | Some n, `Slice, true -> "a slice of " ^ n + | Some n, `Slice, false -> "a slice of an array inside " ^ n + | Some n, `Addr, true -> "the address of " ^ n + | Some n, `Addr, false -> "an address inside " ^ n + | None, `Slice, _ -> "a slice of a temporary array" + | None, `Addr, _ -> "the address of a temporary" + in + (* Reported at the addr or slice itself: a [return] under a [defer], or a + local bound to one, reaches here as a read of a slot, and the caret + belongs on the form that took the address. *) + let fail ~verb ~target ~fix_slice ~fix_addr + ((e : Tast.expr), ((s, kind, exact) as hit)) = + let fix = + (* The slice as written, bounds and all, when the source can be read + back; its root's name otherwise. *) + let rec bound (b : Tast.expr) = + match b.Tast.e with + | Tast.Int (v, _) -> Some (Int64.to_string v) + | Tast.Local i -> f.Tast.snames.(i) + | Tast.Prim (Tast.Cast _, [ x ]) -> bound x + | _ -> None + in + let rebuilt = + match e.Tast.e, f.Tast.snames.(s), exact with + | Tast.Prim (Tast.Slice, [ t; lo; hi ]), Some n, true -> + (match t.Tast.ty, bound lo, bound hi with + | Types.Array (len, _), Some "0", Some h + when h = Int64.to_string len -> + Some ("(slice " ^ n ^ ")") + | _, Some l, Some h -> Some ("(slice " ^ n ^ " " ^ l ^ " " ^ h ^ ")") + | _ -> None) + | _ -> None + in + let written = + match rebuilt, Loc.snippet ~lim:120 e.Tast.loc with + | Some t, _ -> Some t + | None, Some t + when String.length t > 7 && String.sub t 0 7 = "(slice " + && not (String.contains t '\n') + && not (String.ends_with ~suffix:"\xe2\x80\xa6" t) -> Some t + | _ -> None + in + match written, f.Tast.snames.(s), kind, exact with + | Some t, _, `Slice, _ -> + fix_slice ("wrap the slice in clone, as in (clone " ^ t ^ ")") + | None, Some n, `Slice, true -> + fix_slice ("wrap the slice in clone, as in (clone (slice " ^ n ^ "))") + | _, _, `Slice, _ -> fix_slice "wrap the slice in (clone ...)" + | _, _, `Addr, _ -> + let pointee = + match e.Tast.ty with + | Types.Ptr (_, t) -> Types.to_string t + | t -> Types.to_string t + in + fix_addr pointee + in + let whose = + match f.Tast.snames.(s) with + | Some n -> Printf.sprintf "%s is a local of %s" n who + | None -> "That value lives in the frame of " ^ who + in + Loc.failk "check/frame-escape" e.Tast.loc + "%s %s %s%s. %s, and its storage is gone once %s returns, so every \ + later read through it reads whatever the next call leaves there. %s" + (if String.equal who f.Tast.name then who + else String.capitalize_ascii who) + verb (what hit) target whose who fix + in + let rec tails (e : Tast.expr) = + match e.Tast.e with + | Tast.Do es | Tast.Let (_, es) | Tast.WithAlloc (_, es) + | Tast.Handled (_, es) -> + (match List.rev es with x :: _ -> tails x | [] -> ()) + (* A restart clause is a branch of this function whose value is the + form's value when that restart is taken. *) + | Tast.RestartCase (cs, body) -> + List.iter + (fun (c : Tast.rclause) -> + match List.rev c.Tast.rbody with x :: _ -> tails x | [] -> ()) + cs; + tails body + | Tast.If (_, a, b) -> tails a; tails b + | Tast.Match (_, arms) -> + List.iter + (fun (a : Tast.arm) -> + match List.rev a.Tast.abody with x :: _ -> tails x | [] -> ()) + arms + | _ -> + Option.iter + (fail ~verb:"returns" ~target:"" + ~fix_slice:(fun c -> + "Return a copy the caller owns: " ^ c + ^ ", which puts the elements in the context allocator") + ~fix_addr:(fun t -> + if String.equal who f.Tast.name then + "Return the value instead: declare " ^ who + ^ " to return " ^ t ^ " and drop the addr" + else + "Return the value, of type " ^ t + ^ ", instead of its address: drop the addr")) + (escapes 0 e) + in + let returns = not (Types.equal f.Tast.ret Types.Unit) in + List.iter + (Tast.walk (fun (e : Tast.expr) -> + match e.Tast.e with + | Tast.Return (Some v) when returns -> tails v + | Tast.Set (p, v) when not (String.equal f.Tast.name "main") -> + (match place_global p with + | Some g -> + Option.iter + (fail ~verb:"stores" ~target:(" into the global " ^ g) + ~fix_slice:(fun c -> + "Store a copy that outlives the frame: " ^ c + ^ ", which puts the elements in the context allocator") + ~fix_addr:(fun t -> + "Store the value instead: declare " ^ g ^ " as " ^ t + ^ " and drop the addr")) + (escapes 0 v) + | _ -> ()) + | _ -> ())) + f.Tast.body; + if returns then + match List.rev f.Tast.body with x :: _ -> tails x | [] -> () + let box loc (e : Tast.expr) : Tast.expr = let dyn sym args = rt loc Types.Dyn sym args in match e.Tast.ty with @@ -5450,13 +5684,15 @@ and check_fn ctx ~want ?gen loc (params : string list) body = one must not — it is reached by calls that pass none, and a parameter nobody supplies is read off whatever the register held. *) let fenv = if bare then fenv else declare_env fctx fenv in - ctx.env.lifted <- + let lifted = { Tast.name = fname; params = pts; slots = Array.of_list (List.rev fctx.slot_tys); snames = Array.of_list (List.rev fctx.slot_names); ret; body = prefix fbody; fdefers = []; fenv; fparent = Some ctx.owner; floc = loc } - :: ctx.env.lifted; + in + refuse_frame_escapes lifted; + ctx.env.lifted <- lifted :: ctx.env.lifted; let fty = if bare then Types.CFn (pts, ret) else Types.Fn (pts, ret) in (* [Flanfn] and not [Fnval], which is the handler clause's choice and is the same choice for the same reason. [Fnval] exists so that a *name* taken as @@ -5571,13 +5807,15 @@ and check_handler_bind ctx ?want ?(what = "handler-bind") loc clauses body = [flan_signal] reads it off the frame and passes it to whichever clause matched, and it cannot know which of them captured. *) let fenv = declare_env hctx fenv in - ctx.env.lifted <- + let lifted = { Tast.name = fname; params = [ Types.Ptr (Types.Mut, ty) ]; slots = Array.of_list (List.rev hctx.slot_tys); snames = Array.of_list (List.rev hctx.slot_names); ret = Types.Unit; body = prefix hbody; fdefers = []; fenv; fparent = Some ctx.owner; floc = c.Ast.hloc } - :: ctx.env.lifted; + in + refuse_frame_escapes lifted; + ctx.env.lifted <- lifted :: ctx.env.lifted; { Tast.htype = type_id name; hfn = fname; henv = addr }, bind) clauses in @@ -13415,187 +13653,6 @@ let escaping_names ~returns (body : Ast.expr list) : string list = if returns then (match List.rev body with x :: _ -> tails x | [] -> ()); !names -(* A value handed out of [f] that points into [f]'s own frame: returned (the - last form's tails, or a [return]), or stored into a global or a field or - array element of one. Both read a dead frame the moment [f] returns, so - both are refused. - - Deliberately narrow — the exact spellings that can only be wrong, so - nothing that could be valid is ever refused: - - [(addr p)] where [p] is a local, a field of one, or an element of a - local *array* (an array's elements are the frame's bytes; a Vec's or a - slice's are not); - - [(slice a …)] where [a] is such a place of array type; - - a local bound by [let] to one of those and never assigned or addressed - afterwards, which is also how a [return] under a [defer] arrives here. - A parameter is a local: its value is copied into the frame (an array - parameter too), so its address dies with the frame as well. Anything - reached through a [Ptr] is not the frame's, and a struct literal holding - such an address is not looked into. - - The store is let through in two cases where it can be right. In [main], - whose frame outlives everything the program runs. And where the function - sets that same global again elsewhere — the stash-then-restore shape, the - global pointed at the frame only while the frame was live. *) -let refuse_frame_escapes (f : Tast.fn) = - (* Keyed by slot alone: [fresh_slot] never reuses one, so a slot has at - most one binding [Let] in the function. *) - let binds = Hashtbl.create 16 in - let unstable = Hashtbl.create 16 in - let global_sets = Hashtbl.create 8 in - let rec place_global = function - | Tast.Pglobal g -> Some g - | Tast.Pfield (t, _) -> expr_global t - | Tast.Pindex (t, idx) when all_array t.Tast.ty idx -> expr_global t - | _ -> None - and expr_global (e : Tast.expr) = - match e.Tast.e with - | Tast.Global g -> Some g - | Tast.Field (t, _) -> expr_global t - | Tast.Prim (Tast.At, t :: idx) when all_array t.Tast.ty idx -> expr_global t - | _ -> None - (* [(at a i j)] is one node carrying every index; each level stepped must - be an array for the element to be inside [a]'s own bytes. *) - and all_array ty = function - | [] -> true - | _ :: rest -> - (match ty with Types.Array (_, el) -> all_array el rest | _ -> false) - in - List.iter - (Tast.walk (fun (e : Tast.expr) -> - match e.Tast.e with - | Tast.Let (bs, _) -> List.iter (fun (s, v) -> Hashtbl.replace binds s v) bs - | Tast.Set (Tast.Plocal s, _) | Tast.Addr (Tast.Plocal s) -> - Hashtbl.replace unstable s () - | Tast.Set (p, _) -> - Option.iter - (fun g -> - Hashtbl.replace global_sets g - (1 + Option.value ~default:0 (Hashtbl.find_opt global_sets g))) - (place_global p) - | _ -> ())) - f.Tast.body; - (* The local at the root of a place inside this frame, if it is one. *) - let rec root_expr (e : Tast.expr) = - match e.Tast.e with - | Tast.Local s -> Some s - | Tast.Field (t, _) -> root_expr t - | Tast.Prim (Tast.At, t :: idx) when all_array t.Tast.ty idx -> root_expr t - | _ -> None - in - let root_place = function - | Tast.Plocal s -> Some s - | Tast.Pfield (t, _) -> root_expr t - | Tast.Pindex (t, idx) when all_array t.Tast.ty idx -> root_expr t - | _ -> None - in - (* What escapes: the root local, whether it is a slice (else an address), - and whether the place is the bare local rather than a path into it — - only then can the fix be spelled with its name alone. *) - let rec escapes depth (e : Tast.expr) = - match e.Tast.e with - | Tast.Addr p -> - Option.map - (fun s -> - (e, (s, `Addr, (match p with Tast.Plocal _ -> true | _ -> false)))) - (root_place p) - | Tast.Prim (Tast.Slice, [ t; _; _ ]) -> - (match t.Tast.ty with - | Types.Array _ -> - Option.map - (fun s -> - ( e, - (s, `Slice, - (match t.Tast.e with Tast.Local _ -> true | _ -> false)) )) - (root_expr t) - | _ -> None) - | Tast.Local s when depth < 32 && not (Hashtbl.mem unstable s) -> - Option.bind (Hashtbl.find_opt binds s) (escapes (depth + 1)) - | _ -> None - in - (* A slot with no name is a value the function made for itself, such as - the array a literal like [(slice [7 8 9])] is stored in. *) - let what (s, kind, exact) = - match f.Tast.snames.(s), kind, exact with - | Some n, `Slice, true -> "a slice of " ^ n - | Some n, `Slice, false -> "a slice of an array inside " ^ n - | Some n, `Addr, true -> "the address of " ^ n - | Some n, `Addr, false -> "an address inside " ^ n - | None, `Slice, _ -> "a slice of a temporary array" - | None, `Addr, _ -> "the address of a temporary" - in - (* Reported at the addr or slice itself: a [return] under a [defer], or a - local bound to one, reaches here as a read of a slot, and the caret - belongs on the form that took the address. *) - let fail ~verb ~target ~fix_slice ~fix_addr - ((e : Tast.expr), ((s, kind, exact) as hit)) = - let fix = - match f.Tast.snames.(s), kind, exact with - | Some n, `Slice, true -> - fix_slice ("wrap the slice in clone, as in (clone (slice " ^ n ^ "))") - | _, `Slice, _ -> fix_slice "wrap the slice in (clone ...)" - | _, `Addr, _ -> - let pointee = - match e.Tast.ty with - | Types.Ptr (_, t) -> Types.to_string t - | t -> Types.to_string t - in - fix_addr pointee - in - let whose = - match f.Tast.snames.(s) with - | Some n -> Printf.sprintf "%s is a local of %s" n f.Tast.name - | None -> "That value lives in " ^ f.Tast.name ^ "'s frame" - in - Loc.failk "check/frame-escape" e.Tast.loc - "%s %s %s%s. %s, and its storage is gone once %s returns, so every \ - later read through it reads whatever the next call leaves there. %s" - f.Tast.name verb (what hit) target whose f.Tast.name fix - in - let rec tails (e : Tast.expr) = - match e.Tast.e with - | Tast.Do es | Tast.Let (_, es) | Tast.WithAlloc (_, es) -> - (match List.rev es with x :: _ -> tails x | [] -> ()) - | Tast.If (_, a, b) -> tails a; tails b - | Tast.Match (_, arms) -> - List.iter - (fun (a : Tast.arm) -> - match List.rev a.Tast.abody with x :: _ -> tails x | [] -> ()) - arms - | _ -> - Option.iter - (fail ~verb:"returns" ~target:"" - ~fix_slice:(fun c -> - "Return a copy the caller owns: " ^ c - ^ ", which puts the elements in the context allocator") - ~fix_addr:(fun t -> - "Return the value instead: declare " ^ f.Tast.name - ^ " to return " ^ t ^ " and drop the addr")) - (escapes 0 e) - in - let returns = not (Types.equal f.Tast.ret Types.Unit) in - List.iter - (Tast.walk (fun (e : Tast.expr) -> - match e.Tast.e with - | Tast.Return (Some v) when returns -> tails v - | Tast.Set (p, v) when not (String.equal f.Tast.name "main") -> - (match place_global p with - | Some g when Hashtbl.find_opt global_sets g = Some 1 -> - Option.iter - (fail ~verb:"stores" ~target:(" into the global " ^ g) - ~fix_slice:(fun c -> - "Store a copy that outlives the frame: " ^ c - ^ ", which puts the elements in the context allocator") - ~fix_addr:(fun t -> - "Store the value instead: declare " ^ g ^ " as " ^ t - ^ " and drop the addr")) - (escapes 0 v) - | _ -> ()) - | _ -> ())) - f.Tast.body; - if returns then - match List.rev f.Tast.body with x :: _ -> tails x | [] -> () - let rec check_fn env (fn : Ast.fn) : Tast.fn = let params, ret = Hashtbl.find env.fns fn.Ast.name in let ctx = { (invented_ctx env ret) with owner = fn.Ast.name } in diff --git a/test/test_flan.ml b/test/test_flan.ml index cf4aa30b..c1cae02e 100644 --- a/test/test_flan.ml +++ b/test/test_flan.ml @@ -3375,7 +3375,7 @@ let () = ~needle:"mk returns a slice of a"; rejects_check "returning a local bound to a slice of a local array" "(defn mk [] [i32] (let [a [1 2 3 4] s (slice a 1 3)] s))" - ~needle:"(clone (slice a))"; + ~needle:"(clone (slice a 1 3))"; rejects_check "returning a slice of an array parameter" "(defn mk [a [4 i32]] [i32] (slice a))" ~needle:"mk returns a slice of a"; @@ -3403,9 +3403,33 @@ let () = accepts "a local reassigned before it is returned" "(defonce k [3 i32]) \ (defn mk [] [i32] (let [a [1 2 3] s (slice a)] (set s (slice k)) s))"; - accepts "a global stashed and restored" - "(defonce g [i32]) (defonce k [3 i32]) \ - (defn f [] () (let [a [1 2 3]] (set g (slice a)) (set g (slice k))))"; + rejects_check "two slices of locals stored into one global" + "(defonce g [i32]) \ + (defn f [] () (let [a [1 2 3] b [4 5]] (set g (slice a)) (set g (slice b))))" + ~needle:"f stores a slice of a into the global g"; + rejects_check "the fix keeps the slice's bounds" + "(defn mk [a [4 i32]] [i32] (slice a 1 3))" + ~needle:"(clone (slice a 1 3))"; + rejects_check "an fn returning the address of its own local" + "(defn call [f (Fn [] (Ptr i32))] (Ptr i32) (f)) \ + (defn g [] (Ptr i32) (call (fn [] (let [x (i32 4)] (addr x)))))" + ~needle:"This fn returns the address of x"; + rejects_check "an fn returning a slice of its copy of a captured array" + "(defn call [f (Fn [] [i32])] [i32] (f)) \ + (defn g [] i32 (let [a [1 2 3]] (at (call (fn [] (slice a))) 0)))" + ~needle:"This fn returns a slice of a"; + rejects_check "a handler storing a slice of its local into a global" + "(defstruct Oops [code i32]) (defonce g [i32]) \ + (defn main [] i32 \ + (handler-bind [(Oops [c] (let [a [1 2 3]] (set g (slice a))))] \ + (signal (Oops {.code 1}))) 0)" + ~needle:"This handler stores a slice of a into the global g"; + rejects_check "a restart clause answering the address of a local" + "(defstruct Oops [code i32]) \ + (defn mk [p (Ptr i32)] (Ptr i32) (let [x (i32 4)] \ + (restart-case (do (signal (Oops {.code 1})) p) \ + (use-it [] (addr x)))))" + ~needle:"mk returns the address of x"; accepts "main stores its own local into a global" "(defonce g (Ptr i32)) (defn main [] i32 (let [x (i32 5)] (set g (addr x))) 0)"; accepts "a unit function's last form is not returned"