From 5b8c4a68fa64a7cebf6e532e62b1cbfc1a6b9ec1 Mon Sep 17 00:00:00 2001 From: Joseph Ferano Date: Fri, 25 Sep 2026 15:22:44 +0700 Subject: [PATCH] into refuses to copy elements that own storage as they stand, and names (map clone) where clone takes the element --- lib/check.ml | 106 +++++++++++++++++++++++++++++++-- lib/prelude.ml | 18 ++++++ test/programs/into-owning.flan | 22 +++++++ test/test_acceptance.ml | 5 ++ test/test_flan.ml | 28 +++++++++ 5 files changed, 175 insertions(+), 4 deletions(-) create mode 100644 test/programs/into-owning.flan diff --git a/lib/check.ml b/lib/check.ml index ee0c4daf..d2ef76b2 100644 --- a/lib/check.ml +++ b/lib/check.ml @@ -2429,6 +2429,49 @@ and const_steps ro (ty : Types.t) n = let const_copy env (e : Types.t) = if owning env e || holds_dyn env e then None else Some "(clone v)" +(* Whether (clone x) accepts a value of this type — the same arms the clone + builtin takes: a Vec or a Map whose elements own nothing, or a slice whose + elements neither own storage nor hold a dyn. *) +let clone_accepts env (t : Types.t) = + match t with + | Types.Vec _ | Types.Map _ -> not (region_only env t) + | Types.Slice (_, e) -> not (owning env e || holds_dyn env e) + | _ -> false + +(* The end of clone's refusal for a container of owning elements. Pushing + the elements themselves into a second container would copy their headers + and share their blocks, so the advice is a copy of each element where + clone takes one, and otherwise that there is no copy to make. *) +let insert_copies env (t : Types.t) = + let elem = + match t with + | Types.Vec e | Types.Slice (_, e) | Types.Map (_, e) -> Some e + | _ -> None + in + match elem with + | Some e when clone_accepts env e -> + "Build a second container and push a (clone x) of each element into it" + | Some e -> + Printf.sprintf + "Nothing copies what a %s owns either, so read the elements where they \ + are" + (Types.to_string e) + | None -> "Build a second container and insert into it" + +(* A call written back out as source, for a fix that has to repeat what the + reader wrote: names, integers and calls of those. Anything else is [None] + and the caller says the fix in words. *) +let rec spell_form (a : Ast.expr) = + match a.Ast.e with + | Ast.Var v -> Some v + | Ast.Int n -> Some (Int64.to_string n) + | Ast.UInt (_, s) -> Some s + | Ast.Call (f, args) -> + let parts = List.map spell_form (f :: args) in + if List.mem None parts then None + else Some ("(" ^ String.concat " " (List.filter_map Fun.id parts) ^ ")") + | _ -> None + (* A store through a read-only view: a [[const T]] or a (Ptr const T). *) let refuse_const_place env loc (view : Types.t) = match view with @@ -9136,6 +9179,57 @@ and named_call ?(qualified = false) ctx ~want loc name args = fail loc "free takes an owning container — a Vec or a Map — found %s" (Types.to_string other)) + (* Emitted by the prelude's [into] when no (map f) is in the chain, so that + every element pushed is a source element as it stands. A push copies an + element's header, and for an element that owns storage the copy and the + source then share one block: growing an element through either side + reallocates it and frees the block the other still points at. That is a + use after free the program never wrote, under a name that promised a + copy, so it is refused here. A bare (push w (at v 0)) is not: it copies a + header in plain sight, the Odin contract every container follows. + Arguments are the source, then the destination and the transforms as + written — those two only to be spelled back in the fix, never checked. *) + | "into-copies-elements" -> + (match args with + | src :: dst :: transforms -> + let s = check ctx src in + let elem = + match s.Tast.ty with + | Types.Vec e | Types.Slice (_, e) | Types.Array (_, e) -> Some e + | _ -> None + in + (match elem with + | Some e when owning ctx.env e -> + let v = spell_arg "v" src in + let et = Types.to_string e in + let fix = + if clone_accepts ctx.env e then + match spell_form dst, List.map spell_form transforms with + | Some d, ts when not (List.mem None ts) -> + Printf.sprintf + "Add (map clone) to the chain, which copies what each \ + element owns: (into %s)" + (String.concat " " + ((v :: d :: List.filter_map Fun.id ts) @ [ "(map clone)" ])) + | _ -> + "Add (map clone) to the chain, which copies what each element \ + owns" + else + Printf.sprintf + "Nothing copies what a %s owns, so no copy of %s can stand on \ + its own: read the elements where they are, or build each new \ + element and push that" + et v + in + Loc.failk "check/into-shares-elements" src.Ast.loc + "into copies each element of %s as it stands, and an element of \ + %s is a %s, which owns storage — the copy would share each \ + element's block with %s, and growing either one frees the block \ + the other points at. %s" + v v et v fix + | _ -> ()); + expect ctx loc ~want (mk loc Types.Unit Tast.Unit) + | _ -> expect ctx loc ~want (mk loc Types.Unit Tast.Unit)) (* (clone v) uses the current allocator, (clone v a) names one. A deep, independent copy: spec-memory.md's "copying is always explicit". *) | "clone" -> @@ -9171,9 +9265,9 @@ and named_call ?(qualified = false) ctx ~want loc name args = | (Types.Vec _ | Types.Map _) when region_only ctx.env target.Tast.ty -> fail loc "%s cannot be cloned — its elements own storage, and nothing here \ - can walk one to copy what it owns. Build a second container and \ - insert into it" + can walk one to copy what it owns. %s" (Types.to_string target.Tast.ty) + (insert_copies ctx.env target.Tast.ty) (* A slice's elements, copied into a block from the allocator and answered as a slice over it — what (bytes s) does for a string's bytes, and the same lowering. The same refusal as a Vec's, for the @@ -9181,9 +9275,9 @@ and named_call ?(qualified = false) ctx ~want loc name args = | Types.Slice (_, elem) when owning ctx.env elem -> fail loc "%s cannot be cloned — its elements own storage, and nothing here \ - can walk one to copy what it owns. Build a container and insert \ - into it" + can walk one to copy what it owns. %s" (Types.to_string target.Tast.ty) + (insert_copies ctx.env target.Tast.ty) (* The copy is a block from an allocator, which the collector does not walk, so a dyn in it would be a root nothing marks. *) | Types.Slice (_, elem) when holds_dyn ctx.env elem -> @@ -11708,6 +11802,10 @@ let builtins : (string * string * string) list = allocator's free-all or destroy. Refused for elements that own \ storage: a bytewise copy would alias the original's blocks under a \ name promising otherwise."); + ("into-copies-elements", "into-copies-elements [src dst transform...] ()", + "What into writes when its chain has no (map f). Refuses a source whose \ + elements own storage, because pushing them as they stand would share \ + their blocks. Not meant to be written by hand."); (* (Map K V) *) ("map-new", "map-new [K? V? Allocator?] (Map K V)", diff --git a/lib/prelude.ml b/lib/prelude.ml index 904da3c9..c69bf2ca 100644 --- a/lib/prelude.ml +++ b/lib/prelude.ml @@ -2371,6 +2371,15 @@ let source = {flan| (form-sym? head "filter") (recur (- k 1) `(when (~f ~x) ~body)) :else `(into-transform-is-map-or-filter ~t)))))))) +;; Whether any transform in the chain is a (map f). +(defn into-maps? [ts [Form]] bool + (loop [k 0] + (cond + (= k (length ts)) false + (let [items (form-items (at ts k))] + (and (> (length items) 0) (form-sym? (at items 0) "map"))) true + :else (recur (+ k 1))))) + ;; The items of a list form, and the empty slice for anything else — a ;; non-list transform falls into the arity complaint above rather than needing ;; a case of its own. @@ -2423,10 +2432,19 @@ let source = {flan| named? (form-is-sym? from) src (if named? from (gensym)) bind (if named? (form-nil) (form-pair src from)) + ;; With no (map f) in the chain every element pushed is a source + ;; element as it stands, which copies only its header: the checker + ;; refuses that for an element that owns storage. The destination and + ;; the transforms ride along unevaluated, to be written back in the fix. + shares (if (into-maps? (form-rest args 2)) + (form-nil) + (form-cons `(into-copies-elements ~src ~(at args 1) ~@(form-rest args 2)) + (form-nil))) dst (gensym) x (gensym) i (gensym)] `(let [~dst ~(at args 1) ~@bind] + ~@shares (dotimes [~i (length ~src)] (let [~x (at ~src ~i)] ~(into-wrap (form-rest args 2) dst x))) diff --git a/test/programs/into-owning.flan b/test/programs/into-owning.flan new file mode 100644 index 00000000..48bc4aaf --- /dev/null +++ b/test/programs/into-owning.flan @@ -0,0 +1,22 @@ +;;;; into over elements that own storage. Without a (map f) in the chain the +;;;; elements are pushed as they stand, which copies their headers and shares +;;;; their blocks — so that is refused, and (map clone) is the copy that +;;;; compiles. The outer Vecs are in an arena, as a container of owning +;;;; elements has to be; the inner ones are on the heap, where growing one +;;;; through a shared header would free the block the other still points at. + +(defn main [] i32 + (let [a (arena-new 65536) + v (vec-new (Vec i32) a)] + (push v (vec-new i32)) + (push (at v 0) 1) + (let [w (into v (vec-new (Vec i32) a) (map clone))] + (dotimes [i 100] (push (at w 0) i)) + (println (at (at v 0) 0)) ; 1 + (println (length (at v 0))) ; 1 + (println (length (at w 0))) ; 101 + (println (at (at w 0) 100)) ; 99 + (free (at w 0))) + (free (at v 0)) + (arena-destroy a) + 0)) diff --git a/test/test_acceptance.ml b/test/test_acceptance.ml index a0fe1a0f..da83f4ca 100644 --- a/test/test_acceptance.ml +++ b/test/test_acceptance.ml @@ -613,6 +613,11 @@ let () = source transformed in two orders, which have to differ. *) outputs "into" "programs/into.flan" "7 8 9 \n2 4 6 8 10 12 \n4 8 12 \n21\n6 2 4 \n3 1 2 \n3 4 \n2 4 \n1\n"; + (* The fix into's refusal names for owning elements, (map clone): the + copy's inner Vec grows on the heap and the source's is untouched. *) + outputs "into with (map clone)" "programs/into-owning.flan" "1\n1\n101\n99\n"; + outputs ~x86:true "into with (map clone), --x86" "programs/into-owning.flan" + "1\n1\n101\n99\n"; (* The prelude's slice algorithms. Every assertion here is over an input a wrong implementation fails: unsorted with duplicates, negatives and an odd length; a reverse-sorted slice; and a sort of a subslice whose diff --git a/test/test_flan.ml b/test/test_flan.ml index 4d0f57f7..6d534420 100644 --- a/test/test_flan.ml +++ b/test/test_flan.ml @@ -3188,6 +3188,34 @@ let () = rejects_check "clone on a slice of owning elements" "(defn f [v [(Vec i32)]] i32 (length (clone v)))" ~needle:"[(Vec i32)] cannot be cloned"; + (* into with no (map f) pushes the source's elements as they stand, which + for an owning element shares its block — pushing through the copy then + frees the source's. The fix it names is programs/into-owning.flan. *) + rejects_check "into copying owning elements, refused at the source" + "(defn f [a Allocator] i32\n\ + \ (let [v (vec-new (Vec i32) a)\n\ + \ w (into v (vec-new (Vec i32) a) (filter nonempty?))] (length w)))\n\ + (defn nonempty? [x (Vec i32)] bool (> (length x) 0))" + ~needle:"into copies each element of v as it stands, and an element of v \ + is a (Vec i32), which owns storage — the copy would share each \ + element's block with v, and growing either one frees the block \ + the other points at. Add (map clone) to the chain, which copies \ + what each element owns: (into v (vec-new (Vec i32) a) (filter \ + nonempty?) (map clone))"; + accepts "into with (map clone) over owning elements" + "(defn f [a Allocator] i32\n\ + \ (let [v (vec-new (Vec i32) a)\n\ + \ w (into v (vec-new (Vec i32) a) (map clone))] (length w)))"; + accepts "into of plain elements is untouched" + "(defn f [v [i32]] () (let [w (into v (vec-new i32))] (free w)))"; + rejects_check "into copying elements clone cannot copy, explained" + "(defstruct B [xs (Vec i32)])\n\ + (defn f [v [B] a Allocator] i32 (let [w (into v (vec-new B a))] (length w)))" + ~needle:"Nothing copies what a B owns, so no copy of v can stand on its \ + own"; + rejects_check "clone's refusal names a clone of each element" + "(defn f [v [(Vec i32)]] i32 (length (clone v)))" + ~needle:"push a (clone x) of each element into it"; accepts "clone on a slice, with and without an allocator" "(defn f [v [f64] a Allocator] i32 (+ (length (clone v)) (length (clone v a))))";