into refuses to copy elements that own storage as they stand, and names (map clone) where clone takes the element

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 \
+             can walk one to copy what it owns. %s"
-             insert into it"
             (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 \
+             can walk one to copy what it owns. %s"
-             into it"
             (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)",

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)))

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))

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

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))))";