From c6ad71dc5bdc5da0ffee9415c2177288b8989f1b Mon Sep 17 00:00:00 2001 From: Joseph Ferano Date: Fri, 25 Sep 2026 13:30:47 +0700 Subject: [PATCH] A value that owns storage is never copied out of read-only storage, and two arguments at one type variable meet at const --- lib/check.ml | 173 ++++++++++++++++++++++----------- lib/types.ml | 17 ++-- test/programs/const-owned.flan | 39 ++++++++ test/test_acceptance.ml | 6 ++ test/test_flan.ml | 90 ++++++++++++++--- 5 files changed, 247 insertions(+), 78 deletions(-) create mode 100644 test/programs/const-owned.flan diff --git a/lib/check.ml b/lib/check.ml index e42e90ab..60c3244a 100644 --- a/lib/check.ml +++ b/lib/check.ml @@ -556,8 +556,11 @@ type ctx = { the outer scope is a list and the names on it were not all written for this body's sake. *) mutable caught : (string * (binding * int)) list; - (* Locals bound from read-only storage, and the view each came through. *) - mutable const_locals : (int * Types.t) list; + (* Whether the form being checked is the target of a place — indexed, + sliced, a field read, its address taken — rather than a value. Granted by + [check_target] to the one form it checks and withdrawn at the top of + [check]. See [refuse_owned_copy]. *) + mutable place_ok : bool; (* The context this body was lifted out of, so that capture can be transitive: an [fn] inside an [fn] naming a local of the function both were written in is captured by the middle one and then by the inner one @@ -1859,7 +1862,16 @@ let rec bind_ty ?(widen = false) ?(ro = true) subst (pat : Types.t) | Types.Var v, a -> (match List.assoc_opt v !subst with | None -> subst := (v, a) :: !subst; true - | Some b -> Types.equal a b) + | Some b when Types.equal a b -> true + (* Two arguments that differ only in const bind the variable to the + read-only one, whichever came first — the same meeting an [if]'s two + branches have. [expect] converts the writable argument afterwards. *) + | Some b when ro -> + (match Types.const_join a b with + | Some j -> + subst := (v, j) :: List.remove_assoc v !subst; true + | None -> false) + | Some _ -> false) | Types.Slice (m, p), Types.Slice (m', a) when m = m' || (ro && m = Types.Const) -> bind_ty ~ro:(m = Types.Const) subst p a @@ -2198,12 +2210,11 @@ let here loc = mk loc Types.String (Tast.Str (Loc.to_string loc)) an array that is. The last slice stepped through decides, because the const is shallow — an element of a [[const [u8]]] is itself a writable [[u8]], and what it views is not the outer slice's to protect. *) -let rec const_reached ?(local = fun (_ : int) -> None) (e : Tast.expr) = +let rec const_reached (e : Tast.expr) = match e.Tast.e with | Tast.Prim (Tast.At, target :: idx) -> - const_steps (const_reached ~local target) target.Tast.ty (List.length idx) - | Tast.Field (target, _) -> const_reached ~local target - | Tast.Local s -> local s + const_steps (const_reached target) target.Tast.ty (List.length idx) + | Tast.Field (target, _) -> const_reached target | Tast.Deref p -> (match p.Tast.ty with Types.Ptr (Types.Const, _) -> Some p.Tast.ty | _ -> None) | _ -> None @@ -2222,13 +2233,12 @@ and const_steps ro (ty : Types.t) n = compiles. Only for elements that own nothing: an element holding a Vec or a Map — directly or inside a struct — would copy only its header, and the copy would share the original's block. *) -let const_copy (e : Types.t) = - match e with - | Types.Vec _ | Types.Map _ | Types.Named _ -> None - | _ -> Some (Printf.sprintf "(slice (into v (vec-new %s)))" (Types.to_string e)) +let const_copy env (e : Types.t) = + if owning env e then None + else Some (Printf.sprintf "(slice (into v (vec-new %s)))" (Types.to_string e)) (* A store through a read-only view: a [[const T]] or a (Ptr const T). *) -let refuse_const_place loc (view : Types.t) = +let refuse_const_place env loc (view : Types.t) = match view with | Types.Ptr (_, ((Types.Vec _ | Types.Map _) as t)) -> Loc.failk "check/store-through-const" loc @@ -2247,7 +2257,7 @@ let refuse_const_place loc (view : Types.t) = "this writes through a %s, which can only be read, so the element is a \ value and not a place. %s" (Types.to_string view) - (match const_copy elem with + (match const_copy env elem with | Some c -> Printf.sprintf "Write into a slice that can be written: %s copies v's elements \ @@ -3096,14 +3106,14 @@ let numeric_note ~(want : Types.t) ~(got : Types.t) = copies it names compile today: [string] reads any byte slice and [bytes] copies a string, and [into] pushes any slice's elements into a Vec that [slice] then views. *) -let const_note ~(want : Types.t) ~(got : Types.t) = +let const_note env ~(want : Types.t) ~(got : Types.t) = match want, got with | Types.Slice (Types.Mut, e), Types.Slice (Types.Const, e') when Types.equal e e' -> let copy = match e with | Types.Int Types.U8 -> Some "(bytes (string v))" - | _ -> const_copy e + | _ -> const_copy env e in Printf.sprintf " — a %s can only be read, and never becomes a %s that can be written \ @@ -3200,7 +3210,7 @@ let expect ctx loc ~want (got : Tast.expr) = Loc.failk "check/type-mismatch" loc "expected %s, found %s%s%s" (Types.to_string w) (Types.to_string got.Tast.ty) (numeric_note ~want:w ~got:got.Tast.ty) - (const_note ~want:w ~got:got.Tast.ty) + (const_note ctx.env ~want:w ~got:got.Tast.ty) (* Something a [break] may not jump out of, named so the refusal can say which. See [lentry]: it is a barrier and not a blanket refusal, so a loop written @@ -3262,7 +3272,7 @@ let hash_ty = Types.Int Types.U64 would share a slot counter. *) let invented_ctx env ret = { env; ret; slots = 0; slot_tys = []; slot_names = []; scope = []; - defers = []; defer_slot = None; outer = []; outer_what = None; caught = []; const_locals = []; envslot = None; parent = None; in_frames = None; loops = []; tail = false; + defers = []; defer_slot = None; outer = []; outer_what = None; caught = []; place_ok = false; envslot = None; parent = None; in_frames = None; loops = []; tail = false; in_defer = false; defer_ok = false; defer_block = "a nested form"; owner = "" } @@ -3701,7 +3711,51 @@ let tracked_call loc env name (tr : Shim.track) ret (args : Tast.expr list) = | [], [] -> call | pre, post -> mk loc ret (Tast.Do (pre @ [ call ] @ post)) +(* Every expression goes through here, and [check_value] is the one that + knows the forms. What this adds is [refuse_owned_copy], asked of whatever + came back unless the form was checked as the target of a place. *) let rec check ctx ?want (e : Ast.expr) : Tast.expr = + let place = ctx.place_ok in + ctx.place_ok <- false; + let r = check_value ctx ?want e in + if not place then refuse_owned_copy ctx r; + r + +(* A form checked as the target of a place: indexed, sliced, a field read, + measured, its address taken, or handed to a builtin that works on the + container where it stands. *) +and check_target ctx (e : Ast.expr) = + ctx.place_ok <- true; + check ctx e + +(* Decision 81 (2026-09-25). A value that owns storage — a Vec, a Map, or an + array, Option or struct holding one — reached through a [[const T]] or a + (Ptr const T) is not copied out as a value. Its header shares its block + with the original, so a copy that could be grown, freed or handed on as + writable would be the original written through. It is used where it + stands instead: indexed, sliced (to a [[const T]]), its fields read when + they own nothing, or its address taken as a (Ptr const T). Refusing at the + source is the whole rule; there is no tracking of where a copy went. *) +and refuse_owned_copy ctx (r : Tast.expr) = + match const_reached r with + | Some view when owning ctx.env r.Tast.ty -> + let t = Types.to_string r.Tast.ty in + let fix = + match r.Tast.ty with + | (Types.Vec _ | Types.Map _) when not (region_only ctx.env r.Tast.ty) -> + Printf.sprintf "(clone v) copies it into a %s of its own" t + (* TODO.org, "(clone slice)": once clone copies any value that owns + storage, this should say (clone v) too. *) + | _ -> Printf.sprintf "(addr v) gives a (Ptr const %s) to read it through" t + in + Loc.failk "check/const-owned-copy" r.Tast.loc + "this copies a %s out of a %s, which can only be read, and the copy \ + would share its storage with the original. Use it where it stands — \ + index it, slice it or read its fields — or %s" + t (Types.to_string view) fix + | _ -> () + +and check_value ctx ?want (e : Ast.expr) : Tast.expr = let loc = e.Ast.loc in (* Read the permission this form was given and withdraw it in the same breath, so that nothing reached from here inherits it. The two callers @@ -3928,7 +3982,7 @@ let rec check ctx ?want (e : Ast.expr) : Tast.expr = than once — nothing in this milestone builds one — still falls to the ordinary [Ast.Set] arm below, and [indexed] refuses it by name. *) | Ast.Set (Ast.Pindex (target, [ idx ]), v) -> - let target = check ctx target in + let target = check_target ctx target in if target.Tast.ty = Types.Dyn then let i = check ctx ~want:Types.Dyn idx in let v = check ctx ~want:Types.Dyn v in @@ -5010,13 +5064,6 @@ and check_let ctx ?(tail = false) ?want ?(defer_ok = false) loc bs body = | _ -> ()); (* Locals are assignable places; parameters are not. *) let slot = bind ctx b.Ast.bname v.Tast.ty ~assignable:true in - (* A Vec or Map header copied out of read-only storage still - shares its block with the original, so a push through the copy - is a push through the original. The local remembers where it - came from, for [refuse_const_change]. *) - Option.iter - (fun view -> ctx.const_locals <- (slot, view) :: ctx.const_locals) - (const_reached ~local:(const_local ctx) v); (slot, v)) bs in @@ -6502,7 +6549,7 @@ and fields_named env n : Tast.structure option = pointer to one. The auto-deref is inserted here as a real node, so no backend re-derives it. *) and struct_target ctx (target : Ast.expr) : Tast.expr * string = - let t = check ctx target in + let t = check_target ctx target in let has n = fields_named ctx.env n <> None in match t.Tast.ty with | Types.Named n when has n -> t, n @@ -6573,15 +6620,13 @@ and place_const (p : Tast.place) = const_steps (const_reached t) t.Tast.ty (List.length idx) <> None || through_string t.Tast.ty (List.length idx) -and const_local ctx slot = List.assoc_opt slot ctx.const_locals - -(* Growing, shrinking or freeing a Vec or a Map that is read-only storage, or - a copy of one. The backends hand the runtime the container's address, and - the header's block is shared with every copy, so this is the store - [check_place] refuses, made through the header instead of through a [set]. - Writing into the Vec's own buffer is not refused: the const is shallow. *) -and refuse_const_change ctx loc (target : Tast.expr) = - match const_reached ~local:(const_local ctx) target with +(* Growing, shrinking or freeing a Vec or a Map that is read-only storage. + The backends hand the runtime the container's address, so this is the + store [check_place] refuses, made through the header instead of through a + [set]. Writing into the Vec's own buffer is not refused: the const is + shallow. *) +and refuse_const_change _ctx loc (target : Tast.expr) = + match const_reached target with | None -> () | Some view -> let t = Types.to_string target.Tast.ty in @@ -6646,10 +6691,10 @@ and check_place ?(store = true) ctx loc (p : Ast.place) : Tast.place * Types.t = Loc.failk "check/unknown-field" loc ~notes:(declared_note ctx.env sname) "%s has no field %s" sname name | Some i -> - if store then Option.iter (refuse_const_place loc) (const_reached target); + if store then Option.iter (refuse_const_place ctx.env loc) (const_reached target); Tast.Pfield (target, i), (List.nth s.Tast.fields i).Tast.fty) | Ast.Pindex (target, idx) -> - let target = check ctx target in + let target = check_target ctx target in (match target.Tast.ty with (* The same bounds and epoch check the value form gets, through the same helper: an element of a Vec is a place because a Vec element is @@ -6665,7 +6710,7 @@ and check_place ?(store = true) ctx loc (p : Ast.place) : Tast.place * Types.t = let target = check ctx target in (match target.Tast.ty with | Types.Ptr (Types.Const, _) as view when store -> - refuse_const_place loc view + refuse_const_place ctx.env loc view | Types.Ptr (_, t) -> Tast.Pderef target, t | other -> fail loc "deref takes a (Ptr T), found %s" (Types.to_string other)) @@ -6724,7 +6769,7 @@ and index_expr ctx (e : Ast.expr) = and indexed ?place ?(store = true) ctx (target : Tast.expr) (idx : Ast.expr list) = (match place with | Some l when store -> - Option.iter (refuse_const_place l) + Option.iter (refuse_const_place ctx.env l) (const_steps (const_reached target) target.Tast.ty (List.length idx)) | _ -> ()); let rec go ty = function @@ -8087,7 +8132,7 @@ and named_call ?(qualified = false) ctx ~want loc name args = arity ctx loc name 2 args; (match args with | [ target; x ] -> - let target = check ctx target in + let target = check_target ctx target in refuse_const_change ctx loc target; (* A push into a dyn container is a call and nothing else: no allocation guard, no restart, no region check. The dyn runtime owns the storage @@ -8128,7 +8173,7 @@ and named_call ?(qualified = false) ctx ~want loc name args = arity ctx loc name 2 args; (match args with | [ target; n ] -> - let target = check ctx target in + let target = check_target ctx target in refuse_const_change ctx loc target; let n = check ctx ~want:index_ty n in let n64 = @@ -8172,7 +8217,7 @@ and named_call ?(qualified = false) ctx ~want loc name args = is a thing you write, and writing it twice is yours to not do. *) | "free" -> arity ctx loc name 1 args; - let target = check ctx (List.hd args) in + let target = check_target ctx (List.hd args) in refuse_const_change ctx loc target; (* A container of owning elements is refused here, and a reader will assume the opposite — that [free] recurses — so this says why it does @@ -8227,7 +8272,7 @@ and named_call ?(qualified = false) ctx ~want loc name args = (* Checked once, then dispatched on what it turned out to be: checking it inside a guard as well would allocate the target's slots twice and evaluate whatever it was written as twice. *) - let target = check ctx target in + let target = check_target ctx target in let a = allocator_arg ctx loc rest in (match target.Tast.ty with (* The refusal that did *not* come down with the type-level ones, and @@ -8342,7 +8387,7 @@ and named_call ?(qualified = false) ctx ~want loc name args = arity ctx loc name 3 args; (match args with | [ target; k; v ] -> - let target = check ctx target in + let target = check_target ctx target in refuse_const_change ctx loc target; (* A put into a dyn map is a call and nothing else, the way a push into a dyn vec is: the runtime owns the storage, so there is no guard, no @@ -8393,7 +8438,7 @@ and named_call ?(qualified = false) ctx ~want loc name args = arity ctx loc name 2 args; (match args with | [ target; k ] -> - let target = check ctx target in + let target = check_target ctx target in (* A dyn map's absence is nil, not None: the typed map can promise an (Option V) because V was written down, and a dyn map has nothing to write. nil is an ordinary dyn value the caller compares against — @@ -8468,7 +8513,7 @@ and named_call ?(qualified = false) ctx ~want loc name args = arity ctx loc name 2 args; (match args with | [ target; k ] -> - let target = check ctx target in + let target = check_target ctx target in refuse_const_change ctx loc target; let kt, vt = map_kv loc "map-remove" target.Tast.ty in let k = check ctx ~want:kt k in @@ -8506,7 +8551,7 @@ and named_call ?(qualified = false) ctx ~want loc name args = arity ctx loc name 4 args; (match args with | [ target; cur; k; v ] -> - let target = check ctx target in + let target = check_target ctx target in let kt, vt = map_kv loc "map-next" target.Tast.ty in let cur = check ctx ~want:(Types.Ptr (Types.Mut, (Types.Int Types.I64))) cur in let k = check ctx ~want:(Types.Ptr (Types.Mut, kt)) k in @@ -8530,7 +8575,7 @@ and named_call ?(qualified = false) ctx ~want loc name args = arity ctx loc name 2 args; (match args with | [ target; k ] -> - let target = check ctx target in + let target = check_target ctx target in (* The dyn map's question, one word with the typed one. It exists on the dyn side because absence there is nil, and a map can also store nil under a key — (get m k) answering nil cannot tell the two @@ -8849,7 +8894,7 @@ and named_call ?(qualified = false) ctx ~want loc name args = | "length" -> arity ctx loc name 1 args; let target = List.hd args in - let a = check ctx target in + let a = check_target ctx target in (match a.Tast.ty with | Types.Array _ | Types.Slice _ | Types.String -> prim Tast.Len index_ty [ a ] @@ -8876,7 +8921,7 @@ and named_call ?(qualified = false) ctx ~want loc name args = | "at" -> (match args with | target :: idx when idx <> [] -> - let target = check ctx target in + let target = check_target ctx target in (match target.Tast.ty with | Types.Vec _ -> let p, elem = vec_at ctx loc target idx in @@ -8923,7 +8968,7 @@ and named_call ?(qualified = false) ctx ~want loc name args = "slice is (slice a), (slice a lo) or (slice a lo hi) — given %d \ arguments" (List.length args) | target :: bounds -> - let target = check ctx target in + let target = check_target ctx target in let ty = target.Tast.ty in match ty with (* A Vec leaves here: everything below is written around a length the @@ -10004,8 +10049,19 @@ and generic_call ctx ~want loc name vars pats pret args = | Ast.Int _ | Ast.UInt _ | Ast.Float _ | Ast.Byte _ -> true | _ -> false in + (* A bare [$t] an earlier argument bound to a slice or a pointer: + this argument may differ from it only in const, and the two meet + at the read-only one ([Types.const_join]), whichever came first. + So it is checked on its own terms rather than against the + binding. *) + let bound_view = + match pat, p with + | Types.Var v, (Types.Slice _ | Types.Ptr _) + when not (generic_ty p || bound_exactly v) -> Some v + | _ -> None + in let a = - if generic_ty p then check ctx a + if generic_ty p || bound_view <> None then check ctx a else if bound_scalar <> None && not untyped_literal then (* On its own terms first. A form that has no type without a want — [(zeroed)] is the one that matters — refuses here and is @@ -10038,6 +10094,11 @@ and generic_call ctx ~want loc name vars pats pret args = bound to i64 is an ordinary mismatch and gets the ordinary refusal below. *) let handled = + match bound_view, Types.const_join p a.Tast.ty with + | Some v, Some j -> + subst := (v, j) :: List.remove_assoc v !subst; + true + | _ -> match bound_scalar with | Some v when (not (Types.equal p a.Tast.ty)) @@ -10076,7 +10137,7 @@ and generic_call ctx ~want loc name vars pats pret args = " — %s takes a slice it may write through, and a %s can \ only be read%s" name (Types.to_string a.Tast.ty) - (match const_copy e with + (match const_copy ctx.env e with | Some c -> Printf.sprintf ". %s copies v into one that can be written" c | None -> "") @@ -10126,6 +10187,8 @@ and generic_call ctx ~want loc name vars pats pret args = && Types.is_numeric a.Tast.ty && Types.widens_to ~from:a.Tast.ty ~into:f -> widen a.Tast.loc f a + | Some f when Types.const_widens ~from:a.Tast.ty ~into:f -> + { a with Tast.ty = f } | _ -> a) (* And the other widening, for the same reason and at the same moment: a [CFn] argument against an [(Fn [$t] $t)] parameter. @@ -10436,7 +10499,7 @@ and trial ctx f = resource failure into a wrong answer. *) let[@warning "+9"] { env = _; ret = _; slots; slot_tys; slot_names; scope; defers; defer_slot; defer_ok; defer_block; outer = _; - outer_what; caught; const_locals; envslot; parent = _; + outer_what; caught; place_ok; envslot; parent = _; in_frames; loops; tail; in_defer; owner = _ } = ctx in match f () with @@ -10447,7 +10510,7 @@ and trial ctx f = ctx.defers <- defers; ctx.defer_slot <- defer_slot; ctx.defer_ok <- defer_ok; ctx.defer_block <- defer_block; ctx.outer_what <- outer_what; ctx.in_frames <- in_frames; - ctx.caught <- caught; ctx.const_locals <- const_locals; ctx.envslot <- envslot; + ctx.caught <- caught; ctx.place_ok <- place_ok; ctx.envslot <- envslot; ctx.loops <- loops; ctx.tail <- tail; ctx.in_defer <- in_defer; Error d diff --git a/lib/types.ml b/lib/types.ml index eefb0bbf..d2dff244 100644 --- a/lib/types.ml +++ b/lib/types.ml @@ -349,20 +349,21 @@ let rec const_widens ~(from : t) ~(into : t) = equal a b || const_widens ~from:a ~into:b | _ -> false -(* A function of one signature standing where another is wanted, when the - two differ only in const. A parameter may be more permissive than asked — - a function that takes a [[const T]] only reads what it is handed, so a - caller handing it a [[T]] loses nothing — and a result may be less so: a - [[T]] returned where a [[const T]] is wanted is [const_widens]'s case. The - two words are the same either way, so [Check.expect] only retypes. *) -(* The one type two branches of an [if] meet at when they differ only in - const: the read-only one, whichever branch it came from. *) +(* The one type two branches of an [if], or two arguments at one type + variable, meet at when they differ only in const: the read-only one, + whichever came first. *) let const_join a b = if equal a b then Some a else if const_widens ~from:a ~into:b then Some b else if const_widens ~from:b ~into:a then Some a else None +(* A function of one signature standing where another is wanted, when the + two differ only in const. A parameter may be more permissive than asked — + a function that takes a [[const T]] only reads what it is handed, so a + caller handing it a [[T]] loses nothing — and a result may be less so: a + [[T]] returned where a [[const T]] is wanted is [const_widens]'s case. The + two words are the same either way, so [Check.expect] only retypes. *) let fn_accepts ~(from : t list * t) ~(into : t list * t) = let ps', r' = from and ps, r = into in List.length ps = List.length ps' diff --git a/test/programs/const-owned.flan b/test/programs/const-owned.flan new file mode 100644 index 00000000..60f2d142 --- /dev/null +++ b/test/programs/const-owned.flan @@ -0,0 +1,39 @@ +;;;; A Vec reached through a [const (Vec T)] or a (Ptr const (Vec T)) is used +;;;; where it stands — indexed, measured, sliced, its address taken — and never +;;;; copied out as a value; (clone v) is the copy. The refusals are in +;;;; test_flan.ml; this is the half that compiles, on both backends. + +(defstruct Bag [items (Vec i32) n i32]) + +(defn total [vs [const (Vec i32)]] i32 + (let [t 0] + (dotimes [i (length vs)] + (dotimes [j (length (at vs i))] + (set t (+ t (at (at vs i) j))))) + t)) + +(defn first-len [p (Ptr const (Vec i32))] i32 (length (deref p))) + +(defn bag-n [bs [const Bag]] i32 (+ (.n (at bs 0)) (length (.items (at bs 0))))) + +(defn pick [c bool a $t b $t] $t (if c a b)) + +(defn main [] i32 + (let [a (vec-new i32) + b (vec-new i32)] + (push a 1) (push a 2) + (push b 30) + (let [vs [a b] + cv (the-const (slice vs)) + w (clone (at cv 0)) + bags [(Bag {.items b .n 4})]] + (push w 99) + ;; The shallow rule: the Vec's own buffer is writable through the view. + (set (at (at cv 1) 0) 31) + (println (total cv) (length w) (length (at cv 0))) + (println (first-len (addr (at cv 0))) (bag-n (slice bags))) + (println (length (pick true (bytes-view "abc") (bytes "de"))) + (length (pick false (bytes "de") (bytes-view "abc")))))) + 0) + +(defn the-const [s [const (Vec i32)]] [const (Vec i32)] s) diff --git a/test/test_acceptance.ml b/test/test_acceptance.ml index 6aa6fc54..47b9cdda 100644 --- a/test/test_acceptance.ml +++ b/test/test_acceptance.ml @@ -879,6 +879,12 @@ let () = const_slice_out; outputs ~x86:true "const slices, --x86" "programs/const-slice.flan" const_slice_out; + let const_owned_out = "34 3 2\n2 5\n3 3\n" in + outputs "const owned" "programs/const-owned.flan" const_owned_out; + outputs ~opt:"-O0" "const owned, -O0" "programs/const-owned.flan" + const_owned_out; + outputs ~x86:true "const owned, --x86" "programs/const-owned.flan" + const_owned_out; (* (string b). The conversion emits nothing — String and Slice _ are the same %slice — so the rows are about length and ownership rather than arithmetic: a number round-tripped, an empty slice, sub-views whose diff --git a/test/test_flan.ml b/test/test_flan.ml index 3624a82b..a0c8c6ca 100644 --- a/test/test_flan.ml +++ b/test/test_flan.ml @@ -2361,21 +2361,81 @@ let () = "(defn f [p (Ptr const $t)] $t (deref p)) (defn g [q (Ptr i32)] i32 (f q))"; accepts "vec-new reads (Ptr const u8) as a type" "(defn f [] i32 (let [v (vec-new (Ptr const u8))] (length v)))"; - (* A Vec header copied out of read-only storage shares its block, so the - copy is as read-only as the original, through any number of lets. *) - rejects_check "push through a let-bound copy of a const element" - "(defn f [cs [const (Vec i32)]] () (let [v (at cs 0)] (push v 1)))" - ~needle:"reached through a [const (Vec i32)]"; - rejects_check "reserve through a copy of a copy" - "(defn f [cs [const (Vec i32)]] () (let [v (at cs 0) w v] (reserve w 9)))" - ~needle:"reached through a [const (Vec i32)]"; - rejects_check "put through a let-bound copy of a const element" - "(defn f [cs [const (Map string i32)]] () (let [m (at cs 0)] (put m \"a\" 1)))" - ~needle:"reached through a [const (Map string i32)]"; - rejects_check "push into a field of a let-bound copy" - "(defstruct P [v (Vec i32)]) \ - (defn f [cs [const P]] () (let [p (at cs 0)] (push (.v p) 1)))" - ~needle:"take the P it lives in as a [P]"; + (* Decision 81: a value that owns storage, reached through read-only + storage, is used where it stands and never copied out. Every route a + copy could take is refused at the copy. *) + let copied = "this copies a (Vec i32) out of a [const (Vec i32)]" in + List.iter + (fun (name, src) -> rejects_check ("no copy out: " ^ name) src ~needle:copied) + [ "let", "(defn f [cs [const (Vec i32)]] () (let [v (at cs 0)] (push v 1)))"; + "loop binding", + "(defn f [cs [const (Vec i32)]] () (loop [v (at cs 0)] (push v 1)))"; + "if value", + "(defn f [c bool cs [const (Vec i32)]] () \ + (let [v (if c (at cs 0) (at cs 1))] (push v 1)))"; + "do value", + "(defn f [cs [const (Vec i32)]] () (let [v (do (at cs 0))] (push v 1)))"; + "set into a local", + "(defn f [cs [const (Vec i32)]] () \ + (let [v (vec-new i32)] (set v (at cs 0)) (push v 1)))"; + "match binding", + "(defn f [cs [const (Vec i32)]] i32 \ + (match (Some (at cs 0)) (Some v) (do (push v 1) 0) None 0))"; + "array destructure", + "(defn f [cs [const (Vec i32)]] () \ + (let [[a b] [(at cs 0) (at cs 1)]] (push a 1)))"; + "closure capture", + "(defn app [g (Fn [] ())] () (g)) (defn f [cs [const (Vec i32)]] () \ + (let [v (at cs 0)] (app (fn [] (push v 1)))))"; + "passed by value", + "(defn pusher [v (Vec i32)] () (push v 1)) \ + (defn f [cs [const (Vec i32)]] () (pusher (at cs 0)))"; + "returned by value", + "(defn g [cs [const (Vec i32)]] (Vec i32) (at cs 0))"; + "through a generic", + "(defn id [x $t] $t x) (defn f [cs [const (Vec i32)]] () (push (id (at cs 0)) 1))" ]; + rejects_check "no copy out through a const pointer" + "(defn f [p (Ptr const (Vec i32))] () (let [v (deref p)] (push v 1)))" + ~needle:"this copies a (Vec i32) out of a (Ptr const (Vec i32))"; + rejects_check "and the copy that is allowed is named" + "(defn f [cs [const (Vec i32)]] (Vec i32) (at cs 0))" + ~needle:"(clone v) copies it into a (Vec i32) of its own"; + rejects_check "a struct holding a Vec is not copied out either" + "(defstruct P [v (Vec i32)]) (defn f [cs [const P]] P (at cs 0))" + ~needle:"(addr v) gives a (Ptr const P) to read it through"; + rejects_check "nor an array of them" + "(defn f [cs [const [2 (Vec i32)]]] [2 (Vec i32)] (at cs 0))" + ~needle:"this copies a [2 (Vec i32)] out of a [const [2 (Vec i32)]]"; + rejects_check "nor an Option of one" + "(defn f [cs [const (Option (Vec i32))]] (Option (Vec i32)) (at cs 0))" + ~needle:"this copies a (Option (Vec i32)) out"; + rejects_check "nor a field that owns storage" + "(defstruct P [v (Vec i32)]) (defn f [cs [const P]] (Vec i32) (.v (at cs 0)))" + ~needle:"this copies a (Vec i32) out of a [const P]"; + accepts "used where it stands" + "(defstruct P [v (Vec i32) n i32]) \ + (defn f [cs [const (Vec i32)] ps [const P] p (Ptr const (Vec i32))] i32 \ + (+ (at (at cs 0) 1) (length (at cs 0)) (length (slice (at cs 0))) \ + (.n (at ps 0)) (length (.v (at ps 0))) (length (deref p)) \ + (length (deref (addr (at cs 0)))) (length (clone (at cs 0)))))"; + accepts "a copy of a scalar element is still a copy" + "(defn f [cs [const i32]] i32 (let [x (at cs 0)] (set x 5) x))"; + (* The header copy is suggested only for elements that own nothing. *) + rejects_check "no header copy suggested for an array of Vecs" + "(defn f [cs [const [2 (Vec i32)]]] () (set (at cs 0) (at cs 1)))" + ~needle:"take it as a [[2 (Vec i32)]] instead"; + rejects_check "nor for an Option of a Vec" + "(defn f [cs [const (Option (Vec i32))]] () (set (at cs 0) None))" + ~needle:"take it as a [(Option (Vec i32))] instead"; + (* Two arguments at one type variable meet at const, either order. *) + accepts "a generic's arguments join at const" + "(defn pick [c bool a $t b $t] $t (if c a b)) \ + (defn f [c bool cs [const u8] ms [u8]] i32 (+ (length (pick c ms cs)) \ + (length (pick c cs ms))))"; + rejects_check "and the join is read-only" + "(defn pick [c bool a $t b $t] $t (if c a b)) \ + (defn f [c bool cs [const u8] ms [u8]] () (set (at (pick c ms cs) 0) 1))" + ~needle:"this writes through a [const u8]"; rejects_check "no copy of Vec headers is suggested" "(defn f [cs [const (Vec i32)]] () (set (at cs 0) (vec-new i32)))" ~needle:"take it as a [(Vec i32)] instead";