From bc433f8fd9f28adb89b652ee41cd5555757c972f Mon Sep 17 00:00:00 2001 From: Tobias Mock Date: Mon, 9 Oct 2023 21:33:39 +0200 Subject: [PATCH] Explicitly copy captured values in upward closures Otherwise, move by default --- lib/codegen/autogen.ml | 4 +- lib/codegen/helpers.ml | 4 +- lib/typing/env.ml | 36 +++-- lib/typing/exclusivity.ml | 146 ++++++++++++++++----- test/autogen.t/closure.smu | 12 +- test/autogen.t/run.t | 61 ++++++--- test/functions.t/closure_inference.smu | 2 +- test/functions.t/nested_closure_allocs.smu | 48 +++++++ test/functions.t/run.t | 6 + test/misc.t/find_fn.smu | 2 +- test/misc.t/pattern_decls.smu | 3 +- test/modules.t/run.t | 2 +- test/typing.ml | 24 ++++ 13 files changed, 280 insertions(+), 70 deletions(-) create mode 100644 test/functions.t/nested_closure_allocs.smu diff --git a/lib/codegen/autogen.ml b/lib/codegen/autogen.ml index 586bc9c3..e054fe3b 100644 --- a/lib/codegen/autogen.ml +++ b/lib/codegen/autogen.ml @@ -285,8 +285,8 @@ module Make (T : Lltypes_intf.S) (H : Helpers.S) (Arr : Arr_intf.S) = struct in Array.iteri f ctors | Tfun _ -> - (* We can assume this is a closure structure. - The global function case has been filtered in [copy] above. *) + (* We can assume this is a closure structure. The global function case + has been filtered in [copy] above. *) let v = bring_default_var dst in let ptr = bb v.value (Llvm.pointer_type closure_t) "" builder in (* Pointer to environment *) diff --git a/lib/codegen/helpers.ml b/lib/codegen/helpers.ml index bbd20bd6..81ff0601 100644 --- a/lib/codegen/helpers.ml +++ b/lib/codegen/helpers.ml @@ -409,7 +409,9 @@ struct ("Internal Error: Cannot find closed variable: " ^ cl.clname) in (* TODO use dst as prealloc *) - let src = if upward then Auto.copy no_param allocref src else src in + let src = + if upward && cl.clcopy then Auto.copy no_param allocref src else src + in let dst = Llvm.build_struct_gep clsr_ptr i cl.clname builder in (match cl.cltyp with | (Trecord _ | Tvariant _ | Tfun _) when cl.clmut && not upward -> diff --git a/lib/typing/env.ml b/lib/typing/env.ml index 86ed168f..e2aced13 100644 --- a/lib/typing/env.ml +++ b/lib/typing/env.ml @@ -390,30 +390,44 @@ let close_thing is_same modpath env = Or: if they are closures *) (* Const values (and imported ones) are not closed over, they exist module-wide *) let is_imported = is_imported env.modpath mname in + let cleantyp = clean typ in let cl = if const || global || is_imported then None else - let cltyp = typ and clparam = param and clmname = mname in - match clean typ with + let cltyp = typ + and clparam = param + and clmname = mname + and clcopy = false in + (* clcopy will be changed it typing *) + match cleantyp with | Tfun (_, _, Closure _) -> - Some { clname; cltyp; clmut; clparam; clmname } + Some { clname; cltyp; clmut; clparam; clmname; clcopy } | Tfun _ when not param -> None - | _ -> Some { clname; cltyp; clmut; clparam; clmname } + | _ -> + Some { clname; cltyp; clmut; clparam; clmname; clcopy } in let t = - { - tname = clname; - ttyp = typ; - tattr = Dnorm; - tattr_loc = None; - tmname = mname; - } + let t = + { + tname = clname; + ttyp = typ; + tattr = Dnorm; + tattr_loc = None; + tmname = mname; + } + in + match cleantyp with + | Tfun (_, _, Closure _) -> Some t + | Tfun _ when not param -> None + | _ -> Some t in + (cl, t)) in let closed, touched = List.split closed_touched in let closed = List.filter_map Fun.id closed in + let touched = List.filter_map Fun.id touched in match scope.kind with | (Stoplevel usage | Sfunc usage) when is_same scope.kind -> diff --git a/lib/typing/exclusivity.ml b/lib/typing/exclusivity.ml index 6a7cc5e1..ef8abfd7 100644 --- a/lib/typing/exclusivity.ml +++ b/lib/typing/exclusivity.ml @@ -87,6 +87,8 @@ module Id = struct (* Special case for pattern matches in lets *) String.concat "." (List.map snd l) | l -> fmt name ^ "." ^ String.concat "." (List.map snd l) + + let only_id = function Fst (id, _) -> id | Shadowed ((id, _), _) -> id end type borrow = { @@ -416,6 +418,48 @@ let move_b loc special b = let borrowed = { b.borrowed with bid = b.parent } in { b with loc; special; borrowed } +let move_closed (tree : Typed_tree.typed_expr) c = + (* Prepend a move of closure [c] to [tree] *) + let var = make_var tree.loc c.clname c.clmname c.cltyp in + let move = { var with expr = Move var } in + { tree with expr = Sequence (move, tree) } + +let get_closed_make_usage usage tree (use : touched) = + match usage with + | Usage.Uread -> (tree, Usage.of_attr use.tattr) + | Umove -> ( + match clean tree.typ with + | Tfun (_, _, Closure cls) -> ( + match + List.find_opt (fun c -> String.equal c.clname use.tname) cls + with + | Some c -> + if c.clcopy then (tree, Uread) + else + (* Move the closed variable into the closure *) + (move_closed tree c, Umove) + | None -> (* Touched but not closed? Let's read it *) (tree, Uread)) + | Tfun _ -> (tree, Uread) + | _ -> failwith "Internal Error: Not a function type") + | Uset | Umut -> failwith "unreachable" + +let get_closed_make_usage_delayed tree b = + (* Compared to above, we are implicitly in the [Umove] usage *) + match clean tree.typ with + | Tfun (_, _, Closure cls) -> ( + let id = Id.only_id b.borrowed.bid in + match List.find_opt (fun c -> String.equal c.clname id) cls with + | Some c -> + if c.clcopy then (tree, Usage.Uread) + else + (* Move the closed variable into the closure *) + (move_closed tree c, Umove) + | None -> (* Touched but not closed? Let's read it *) (tree, Uread)) + | Tfun _ -> failwith "Oh really?!" + | _ -> failwith "Internal Error: Not a function type" + +let make_usage tree (use : touched) = (tree, Usage.of_attr use.tattr) + let rec check_tree env mut ((bpart, special) as bdata) tree hist = match tree.expr with | Var (borrowed, mname) -> @@ -486,37 +530,51 @@ let rec check_tree env mut ((bpart, special) as bdata) tree hist = Bmove (m, l) in - let borrow_delayed delayed = + let borrow_delayed delayed tree usage = let find_borrow usage b = match Map.find_opt b.borrowed.bid env with - (* | Some b when bind -> b.imm *) | Some { imm; delayed = _; bind_only } -> - List.map (borrow bind_only usage) imm + List.map (fun b -> borrow bind_only usage b) imm | None -> [] in - let f acc binding = - let bs = - match binding with - | Bmove (b, _) -> find_borrow Umove b - | Borrow b -> find_borrow Uread b - | Borrow_mut (b, Set) -> find_borrow Uset b - | Borrow_mut (b, Dont_set) -> find_borrow Umut b - | Bown _ -> failwith "Internal Error: A borrowed thing isn't owned" + (* Delayed things only appear in functions. And functions are either + used = Uread or moved = Umove. They should never be mutated. We + mutate the [tree] to add the moves of moved bindings captured by the + closure which is being read *) + let f (tree, acc) binding = + let tree, bs = + match usage with + | Usage.Uread -> ( + ( tree, + match binding with + | Bmove (b, _) -> find_borrow Umove b + | Borrow b -> find_borrow Uread b + | Borrow_mut (b, Set) -> find_borrow Uset b + | Borrow_mut (b, Dont_set) -> find_borrow Umut b + | Bown _ -> + failwith "Internal Error: A borrowed thing isn't owned" )) + | Umove -> ( + match binding with + | Bmove (b, _) | Borrow b | Borrow_mut (b, _) -> + let tree, usage = get_closed_make_usage_delayed tree b in + (tree, find_borrow usage b) + | Bown _ -> + failwith "Internal Error: A borrowed thing isn't owned") + | Uset | Umut -> failwith "hmm" in - List.rev_append bs acc + (tree, List.rev_append bs acc) in - List.fold_left f [] delayed + List.fold_left f (tree, []) delayed in - let borrow = + let tree, borrow = match Map.find_opt bid env with - (* | Some b when bind -> b *) | Some { imm; delayed; bind_only } -> - let delayed = borrow_delayed delayed in + let tree, delayed = borrow_delayed delayed tree mut in forbid_conditional_borrow loc imm mut; let imm = List.map (borrow bind_only mut) imm @ delayed in - { imm; delayed = []; bind_only = false } - | None -> imm [] + (tree, { imm; delayed = []; bind_only = false }) + | None -> (tree, imm []) in (* Don't add to hist here. Other expressions where the value is used will take care of this *) @@ -740,10 +798,17 @@ let rec check_tree env mut ((bpart, special) as bdata) tree hist = let expr = Mutual_rec_decls (decls, cont) in ({ tree with expr }, v, hs) | Lambda (_, abs) -> - let imm = check_abstraction env tree.loc abs.func.touched hist in + let usage = get_closed_make_usage mut in + (* Lambdas immediately borrow (and capture) their closed objects, so we + return a modified [tree] here which contains the needed moves *) + let tree, imm = check_abstraction env tree usage abs.func.touched hist in (tree, { imm; delayed = []; bind_only = false }, hist) | Function (name, u, abs, cont) -> - let bindings = check_abstraction env tree.loc abs.func.touched hist in + (* Uread means it's not moved. The function is defined here, it might be + moved later, but not here *) + let _, bindings = + check_abstraction env tree make_usage abs.func.touched hist + in let env = match List.rev bindings with | [] -> env @@ -776,8 +841,8 @@ and check_let ~tl loc env id lhs rmut pass hist = | true, Dmove -> (Umove, false, false) | true, Dnorm -> (* For rvalues, default to move *) (Umove, false, true) | false, Dnorm -> - (* Cannot borrow mutable bindings at top level. We defer error generation until - we are sure the rhs is really borrowed *) + (* Cannot borrow mutable bindings at top level. We defer error + generation until we are sure the rhs is really borrowed *) (Uread, rmut && tl, false) | false, Dmove -> (Umove, false, false) | false, Dmut -> failwith "unreachable" @@ -810,7 +875,8 @@ and check_let ~tl loc env id lhs rmut pass hist = ([ Bown id ], hs) | b -> (* Switch order so that first move appears near the head of borrow list. - This way, the first move is reported first (if both move the same thing) *) + This way, the first move is reported first (if both move the same + thing) *) let bindings, hist = List.fold_right (fun b (bindings, hist) -> @@ -843,16 +909,16 @@ and check_bind env name expr hist = in (e, b, env, hist) -and check_abstraction env loc touched hist = +and check_abstraction env tree usage touched hist = List.fold_left - (fun bindings (use : touched) -> + (fun (tree, bindings) (use : touched) -> (* For moved values, don't check touched here. Instead, add them as bindings later so they get moved on first use *) - let usage = Usage.of_attr use.tattr in - let var = make_var loc use.tname use.tmname use.ttyp in + let tree, usage = usage tree use in + let var = make_var tree.loc use.tname use.tmname use.ttyp in let _, b, _ = check_tree env usage no_bdata var hist in - b.imm @ bindings) - [] touched + (tree, b.imm @ bindings)) + (tree, []) touched let check_item (env, bind, mut, part, hist) = function | Tl_let ({ loc; id; rmut; pass; lhs; uniq = _ } as e) -> @@ -869,8 +935,16 @@ let check_item (env, bind, mut, part, hist) = function (* Basically a sequence *) let e, b, hs = check_tree env Uread no_bdata e hist in ((env, bind, mut, part, add_hist b hs), Tl_expr e) - | Tl_function (loc, name, _, abs) as f -> - let bindings = check_abstraction env loc abs.func.touched hist in + | Tl_function (_, name, _, abs) as f -> + (* Functions don't caputure on definition, but on first usage. This comes + in handy here as we don't have a correct tree to pass to + [check_abstraction]. Passing [abs.body] doesn't make any sense here. + The returned modified tree is discareded anyway so no harm is done. But + this only works if the assumption holds that capture happens later, + through the delayed bindings. See also [Function] above *) + let _, bindings = + check_abstraction env abs.body make_usage abs.func.touched hist + in let env = match List.rev bindings with | [] -> env @@ -914,8 +988,9 @@ let check_tree ~mname pts pns touched body = { ord = !borrow_state; loc; borrowed; parent = bid; special = Sp_no } in - (* Shadowing between touched variables and parameters is impossible. If a parameter - exists with the same name, the variable would not have been closed over / touched *) + (* Shadowing between touched variables and parameters is impossible. If a + parameter exists with the same name, the variable would not have been + closed over / touched *) (* touched variables *) let env, hist = List.fold_left @@ -931,8 +1006,9 @@ let check_tree ~mname pts pns touched body = let env, hist = List.fold_left (fun (map, hs) (n, _) -> - (* Parameters are not owned, but using them as owned here makes it easier for - borrow checking. Correct usage of mutable parameters is already handled in typing.ml *) + (* Parameters are not owned, but using them as owned here makes it + easier for borrow checking. Correct usage of mutable parameters is + already handled in typing.ml *) let id = new_id n None in (* Parameters get no mname *) assert (Id.equal id (Fst (n, None))); diff --git a/test/autogen.t/closure.smu b/test/autogen.t/closure.smu index 19592da7..d49b2236 100644 --- a/test/autogen.t/closure.smu +++ b/test/autogen.t/closure.smu @@ -4,12 +4,20 @@ (+ a 1)) capture) - (def _ {(copy (hmm))}) +(defn hmm-move [] + (def {a} {1}) + -- a is not explicitly copied, thus moved + (defn capture [] + (+ a 1)) + capture) + +(def _ {(hmm-move)}) + (defn test [] (def a ["hello"]) - (fn [] (print a.[0]))) + (fn :copy a [] (print a.[0]))) (def c (test)) ((copy c)) diff --git a/test/autogen.t/run.t b/test/autogen.t/run.t index b0690308..fc5e237a 100644 --- a/test/autogen.t/run.t +++ b/test/autogen.t/run.t @@ -544,6 +544,15 @@ Copy closures ret i64 %add } + define i64 @schmu_capture__2(i8* %0) { + entry: + %clsr = bitcast i8* %0 to { i8*, i8*, i64 }* + %a = getelementptr inbounds { i8*, i8*, i64 }, { i8*, i8*, i64 }* %clsr, i32 0, i32 2 + %a1 = load i64, i64* %a, align 8 + %add = add i64 %a1, 1 + ret i64 %add + } + define void @schmu_hmm(%closure* noalias %0) { entry: %1 = alloca %tuple_int, align 8 @@ -553,8 +562,6 @@ Copy closures store i8* bitcast (i64 (i8*)* @schmu_capture to i8*), i8** %funptr2, align 8 %2 = tail call i8* @malloc(i64 24) %clsr_schmu_capture = bitcast i8* %2 to { i8*, i8*, i64 }* - %3 = alloca i64, align 8 - store i64 1, i64* %3, align 8 %a = getelementptr inbounds { i8*, i8*, i64 }, { i8*, i8*, i64 }* %clsr_schmu_capture, i32 0, i32 2 store i64 1, i64* %a, align 8 %ctor3 = bitcast { i8*, i8*, i64 }* %clsr_schmu_capture to i8** @@ -566,6 +573,26 @@ Copy closures ret void } + define void @schmu_hmm-move(%closure* noalias %0) { + entry: + %1 = alloca %tuple_int, align 8 + %"01" = bitcast %tuple_int* %1 to i64* + store i64 1, i64* %"01", align 8 + %funptr2 = bitcast %closure* %0 to i8** + store i8* bitcast (i64 (i8*)* @schmu_capture__2 to i8*), i8** %funptr2, align 8 + %2 = tail call i8* @malloc(i64 24) + %clsr_schmu_capture__2 = bitcast i8* %2 to { i8*, i8*, i64 }* + %a = getelementptr inbounds { i8*, i8*, i64 }, { i8*, i8*, i64 }* %clsr_schmu_capture__2, i32 0, i32 2 + store i64 1, i64* %a, align 8 + %ctor3 = bitcast { i8*, i8*, i64 }* %clsr_schmu_capture__2 to i8** + store i8* bitcast (i8* (i8*)* @__ctor_tup-i to i8*), i8** %ctor3, align 8 + %dtor = getelementptr inbounds { i8*, i8*, i64 }, { i8*, i8*, i64 }* %clsr_schmu_capture__2, i32 0, i32 1 + store i8* null, i8** %dtor, align 8 + %envptr = getelementptr inbounds %closure, %closure* %0, i32 0, i32 1 + store i8* %2, i8** %envptr, align 8 + ret void + } + define void @schmu_test(%closure* noalias %0) { entry: %1 = tail call i8* @malloc(i64 24) @@ -752,26 +779,30 @@ Copy closures define i64 @main(i64 %arg) { entry: %0 = alloca %tuple_fn_.int, align 8 - %"02" = bitcast %tuple_fn_.int* %0 to %closure* + %"03" = bitcast %tuple_fn_.int* %0 to %closure* %ret = alloca %closure, align 8 call void @schmu_hmm(%closure* %ret) - %1 = bitcast %closure* %"02" to i8* + %1 = bitcast %closure* %"03" to i8* %2 = bitcast %closure* %ret to i8* call void @llvm.memcpy.p0i8.p0i8.i64(i8* %1, i8* %2, i64 16, i1 false) - call void @__copy_.i(%closure* %"02") + call void @__copy_.i(%closure* %"03") + %3 = alloca %tuple_fn_.int, align 8 + %"014" = bitcast %tuple_fn_.int* %3 to %closure* + call void @schmu_hmm-move(%closure* %"014") call void @schmu_test(%closure* @schmu_c) - %3 = alloca %closure, align 8 - %4 = bitcast %closure* %3 to i8* - call void @llvm.memcpy.p0i8.p0i8.i64(i8* %4, i8* bitcast (%closure* @schmu_c to i8*), i64 16, i1 false) - call void @__copy_.u(%closure* %3) - %funcptr3 = bitcast %closure* %3 to i8** - %loadtmp = load i8*, i8** %funcptr3, align 8 + %4 = alloca %closure, align 8 + %5 = bitcast %closure* %4 to i8* + call void @llvm.memcpy.p0i8.p0i8.i64(i8* %5, i8* bitcast (%closure* @schmu_c to i8*), i64 16, i1 false) + call void @__copy_.u(%closure* %4) + %funcptr5 = bitcast %closure* %4 to i8** + %loadtmp = load i8*, i8** %funcptr5, align 8 %casttmp = bitcast i8* %loadtmp to void (i8*)* - %envptr = getelementptr inbounds %closure, %closure* %3, i32 0, i32 1 - %loadtmp1 = load i8*, i8** %envptr, align 8 - call void %casttmp(i8* %loadtmp1) - call void @__free_.u(%closure* %3) + %envptr = getelementptr inbounds %closure, %closure* %4, i32 0, i32 1 + %loadtmp2 = load i8*, i8** %envptr, align 8 + call void %casttmp(i8* %loadtmp2) + call void @__free_.u(%closure* %4) call void @__free_.u(%closure* @schmu_c) + call void @__free_tup-.i(%tuple_fn_.int* %3) call void @__free_tup-.i(%tuple_fn_.int* %0) call void @__free_.i(%closure* %ret) ret i64 0 diff --git a/test/functions.t/closure_inference.smu b/test/functions.t/closure_inference.smu index 317cbcf9..70931765 100644 --- a/test/functions.t/closure_inference.smu +++ b/test/functions.t/closure_inference.smu @@ -31,7 +31,7 @@ print)) (defn alt [a b] - (fn [buf] -- This variable is polymorphic + (fn :copy a b [buf] -- This variable is polymorphic (match (a buf) ((#ok r) (#ok r)) ((#err _) (b buf))))) diff --git a/test/functions.t/nested_closure_allocs.smu b/test/functions.t/nested_closure_allocs.smu new file mode 100644 index 00000000..ef608df8 --- /dev/null +++ b/test/functions.t/nested_closure_allocs.smu @@ -0,0 +1,48 @@ +(type view {:start int :len int}) +(type (success 'a) {:rem view :mtch 'a}) +(type (parse-result 'a) ((#ok (success 'a)) (#err view))) + +(defn char [c] + (fn [buf view] + (if (char-equal buf.[view.start] c) + (#ok {:mtch {@view :len 1} + :rem {:start (+ 1 view.start) :len (- view.len 1)}}) + (#err view)))) + +(defn alt [alts!] + (fn [buf view] + (defn aux [i] + (if (= i (array/length alts)) + (#err view) + (match (alts.[i] buf view) + ((#ok r) (#ok r)) + ((#err _) (aux (+ i 1)))))) + (aux 0))) + +-- same thing with a named function +(defn alt-named [alts!] + (defn named3 [buf view] + (defn aux [i] + (if (= i (array/length alts)) + (#err view) + (match (alts.[i] buf view) + ((#ok r) (#ok r)) + ((#err _) (aux (+ i 1)))))) + (aux 0)) + named3) + +(defn view-of-string [str] + {:start 0 :len (array/length str)}) + +(def x "x") +(def lx (view-of-string x)) +(def ix "ix") +(def li (view-of-string ix)) +(def xi "xi") +(def l0 (view-of-string xi)) + +(ignore (alt-named ![(char 'x') (char 'i')])) +(def c (alt ![(char 'x') (char 'i')])) +(ignore (c x lx)) +(ignore (c ix li)) +(ignore (c xi l0)) diff --git a/test/functions.t/run.t b/test/functions.t/run.t index 4bb88ef5..80f4dfbd 100644 --- a/test/functions.t/run.t +++ b/test/functions.t/run.t @@ -2548,3 +2548,9 @@ Function call returning a polymorphic function attributes #0 = { argmemonly nofree nounwind willreturn } a foo 10 bar + +Check allocations of nested closures + $ schmu nested_closure_allocs.smu + $ valgrind ./nested_closure_allocs 2>&1 | grep allocs | cut -f 5- -d '=' + Command: ./nested_closure_allocs + total heap usage: 8 allocs, 8 frees, 240 bytes allocated diff --git a/test/misc.t/find_fn.smu b/test/misc.t/find_fn.smu index 83d6a6bf..c9194e51 100644 --- a/test/misc.t/find_fn.smu +++ b/test/misc.t/find_fn.smu @@ -3,4 +3,4 @@ (defn capture [] (+ a 1)) -(def _ {capture}) +(def _ {(copy capture)}) diff --git a/test/misc.t/pattern_decls.smu b/test/misc.t/pattern_decls.smu index e16f4588..e5e46605 100644 --- a/test/misc.t/pattern_decls.smu +++ b/test/misc.t/pattern_decls.smu @@ -11,6 +11,7 @@ -- pattern matched thing is a closure (defn hmm [{x _}] - (fn [] (x))) + (fn :copy x [] (x))) +-- this case is strange. The tuple needs to be moved right now ((hmm {(fn [] (print "lol")) 10})) diff --git a/test/modules.t/run.t b/test/modules.t/run.t index ee83881f..1d6df7c3 100644 --- a/test/modules.t/run.t +++ b/test/modules.t/run.t @@ -428,7 +428,7 @@ Simplest module with 1 type and 1 nonpolymorphic function declare void @free(i8* %0) $ cat malloc_some.smi - (()((5:Mtype(((9:pos_fname15:malloc_some.smu)(8:pos_lnum1:1)(7:pos_bol1:0)(8:pos_cnum1:0))((9:pos_fname15:malloc_some.smu)(8:pos_lnum1:1)(7:pos_bol1:0)(8:pos_cnum2:32)))(8:Tvariant()18:malloc_some/either(((5:cname4:left)(4:ctyp())(5:index1:4))((5:cname5:right)(4:ctyp())(5:index1:5)))))(4:Mfun(((9:pos_fname15:malloc_some.smu)(8:pos_lnum1:3)(7:pos_bol2:34)(8:pos_cnum2:35))((9:pos_fname15:malloc_some.smu)(8:pos_lnum1:3)(7:pos_bol2:34)(8:pos_cnum2:62)))(4:Tfun(((2:pt4:Tint)(5:pattr5:Dnorm))((2:pt4:Tint)(5:pattr5:Dnorm)))4:Tint6:Simple)((4:user8:add_ints)(4:call(20:malloc_some_add_ints))))(4:Mext(((9:pos_fname15:malloc_some.smu)(8:pos_lnum1:5)(7:pos_bol2:65)(8:pos_cnum2:66))((9:pos_fname15:malloc_some.smu)(8:pos_lnum1:5)(7:pos_bol2:65)(8:pos_cnum2:74)))4:Tint((4:user1:a)(4:call(13:malloc_some_a)))5:false)(4:Mext(((9:pos_fname15:malloc_some.smu)(8:pos_lnum1:7)(7:pos_bol2:77)(8:pos_cnum2:78))((9:pos_fname15:malloc_some.smu)(8:pos_lnum1:7)(7:pos_bol2:77)(8:pos_cnum2:98)))4:Tint((4:user1:b)(4:call(13:malloc_some_b)))5:false)(9:Mpoly_fun(((9:pos_fname15:malloc_some.smu)(8:pos_lnum1:9)(7:pos_bol3:101)(8:pos_cnum3:102))((9:pos_fname15:malloc_some.smu)(8:pos_lnum1:9)(7:pos_bol3:101)(8:pos_cnum3:122)))((7:nparams(1:x))(4:body((3:typ(4:Qvar1:1))(4:expr(4:Move((3:typ(4:Qvar1:1))(4:expr(3:App(6:callee((3:typ(4:Tfun(((2:pt(4:Qvar1:1))(5:pattr5:Dnorm)))(4:Qvar1:1)6:Simple))(4:expr(3:Var4:copy()))(4:attr((5:const5:false)(6:global5:false)(3:mut5:false)))(3:loc(((9:pos_fname15:malloc_some.smu)(8:pos_lnum1:9)(7:pos_bol3:101)(8:pos_cnum3:115))((9:pos_fname15:malloc_some.smu)(8:pos_lnum1:9)(7:pos_bol3:101)(8:pos_cnum3:119))))))(4:args((((3:typ(4:Qvar1:1))(4:expr(3:Var1:x()))(4:attr((5:const5:false)(6:global5:false)(3:mut5:false)))(3:loc(((9:pos_fname15:malloc_some.smu)(8:pos_lnum1:9)(7:pos_bol3:101)(8:pos_cnum3:120))((9:pos_fname15:malloc_some.smu)(8:pos_lnum1:9)(7:pos_bol3:101)(8:pos_cnum3:121)))))5:Dnorm)))))(4:attr((5:const5:false)(6:global5:false)(3:mut5:false)))(3:loc(((9:pos_fname15:malloc_some.smu)(8:pos_lnum1:9)(7:pos_bol3:101)(8:pos_cnum3:115))((9:pos_fname15:malloc_some.smu)(8:pos_lnum1:9)(7:pos_bol3:101)(8:pos_cnum3:121)))))))(4:attr((5:const5:false)(6:global5:false)(3:mut5:false)))(3:loc(((9:pos_fname15:malloc_some.smu)(8:pos_lnum1:9)(7:pos_bol3:101)(8:pos_cnum3:115))((9:pos_fname15:malloc_some.smu)(8:pos_lnum1:9)(7:pos_bol3:101)(8:pos_cnum3:121))))))(4:func((7:tparams(((2:pt(4:Qvar1:1))(5:pattr5:Dnorm))))(3:ret(4:Qvar1:1))(4:kind6:Simple)(7:touched(((5:tname4:copy)(4:ttyp(4:Tfun(((2:pt(4:Qvar1:2))(5:pattr5:Dnorm)))(4:Qvar1:2)6:Simple))(5:tattr5:Dnorm)(9:tattr_loc())(6:tmname()))))))(6:inline5:false))2:id())(4:Mext(((9:pos_fname15:malloc_some.smu)(8:pos_lnum2:11)(7:pos_bol3:125)(8:pos_cnum3:126))((9:pos_fname15:malloc_some.smu)(8:pos_lnum2:11)(7:pos_bol3:125)(8:pos_cnum3:141)))(6:Tarray4:Tint)((4:user5:vtest)(4:call(17:malloc_some_vtest)))5:false)(4:Mext(((9:pos_fname15:malloc_some.smu)(8:pos_lnum2:12)(7:pos_bol3:143)(8:pos_cnum3:144))((9:pos_fname15:malloc_some.smu)(8:pos_lnum2:12)(7:pos_bol3:143)(8:pos_cnum3:158)))(6:Tarray4:Tint)((4:user6:vtest2)(4:call(18:malloc_some_vtest2)))5:false))()) + (()((5:Mtype(((9:pos_fname15:malloc_some.smu)(8:pos_lnum1:1)(7:pos_bol1:0)(8:pos_cnum1:0))((9:pos_fname15:malloc_some.smu)(8:pos_lnum1:1)(7:pos_bol1:0)(8:pos_cnum2:32)))(8:Tvariant()18:malloc_some/either(((5:cname4:left)(4:ctyp())(5:index1:4))((5:cname5:right)(4:ctyp())(5:index1:5)))))(4:Mfun(((9:pos_fname15:malloc_some.smu)(8:pos_lnum1:3)(7:pos_bol2:34)(8:pos_cnum2:35))((9:pos_fname15:malloc_some.smu)(8:pos_lnum1:3)(7:pos_bol2:34)(8:pos_cnum2:62)))(4:Tfun(((2:pt4:Tint)(5:pattr5:Dnorm))((2:pt4:Tint)(5:pattr5:Dnorm)))4:Tint6:Simple)((4:user8:add_ints)(4:call(20:malloc_some_add_ints))))(4:Mext(((9:pos_fname15:malloc_some.smu)(8:pos_lnum1:5)(7:pos_bol2:65)(8:pos_cnum2:66))((9:pos_fname15:malloc_some.smu)(8:pos_lnum1:5)(7:pos_bol2:65)(8:pos_cnum2:74)))4:Tint((4:user1:a)(4:call(13:malloc_some_a)))5:false)(4:Mext(((9:pos_fname15:malloc_some.smu)(8:pos_lnum1:7)(7:pos_bol2:77)(8:pos_cnum2:78))((9:pos_fname15:malloc_some.smu)(8:pos_lnum1:7)(7:pos_bol2:77)(8:pos_cnum2:98)))4:Tint((4:user1:b)(4:call(13:malloc_some_b)))5:false)(9:Mpoly_fun(((9:pos_fname15:malloc_some.smu)(8:pos_lnum1:9)(7:pos_bol3:101)(8:pos_cnum3:102))((9:pos_fname15:malloc_some.smu)(8:pos_lnum1:9)(7:pos_bol3:101)(8:pos_cnum3:122)))((7:nparams(1:x))(4:body((3:typ(4:Qvar1:1))(4:expr(4:Move((3:typ(4:Qvar1:1))(4:expr(3:App(6:callee((3:typ(4:Tfun(((2:pt(4:Qvar1:1))(5:pattr5:Dnorm)))(4:Qvar1:1)6:Simple))(4:expr(3:Var4:copy()))(4:attr((5:const5:false)(6:global5:false)(3:mut5:false)))(3:loc(((9:pos_fname15:malloc_some.smu)(8:pos_lnum1:9)(7:pos_bol3:101)(8:pos_cnum3:115))((9:pos_fname15:malloc_some.smu)(8:pos_lnum1:9)(7:pos_bol3:101)(8:pos_cnum3:119))))))(4:args((((3:typ(4:Qvar1:1))(4:expr(3:Var1:x()))(4:attr((5:const5:false)(6:global5:false)(3:mut5:false)))(3:loc(((9:pos_fname15:malloc_some.smu)(8:pos_lnum1:9)(7:pos_bol3:101)(8:pos_cnum3:120))((9:pos_fname15:malloc_some.smu)(8:pos_lnum1:9)(7:pos_bol3:101)(8:pos_cnum3:121)))))5:Dnorm)))))(4:attr((5:const5:false)(6:global5:false)(3:mut5:false)))(3:loc(((9:pos_fname15:malloc_some.smu)(8:pos_lnum1:9)(7:pos_bol3:101)(8:pos_cnum3:115))((9:pos_fname15:malloc_some.smu)(8:pos_lnum1:9)(7:pos_bol3:101)(8:pos_cnum3:121)))))))(4:attr((5:const5:false)(6:global5:false)(3:mut5:false)))(3:loc(((9:pos_fname15:malloc_some.smu)(8:pos_lnum1:9)(7:pos_bol3:101)(8:pos_cnum3:115))((9:pos_fname15:malloc_some.smu)(8:pos_lnum1:9)(7:pos_bol3:101)(8:pos_cnum3:121))))))(4:func((7:tparams(((2:pt(4:Qvar1:1))(5:pattr5:Dnorm))))(3:ret(4:Qvar1:1))(4:kind6:Simple)(7:touched())))(6:inline5:false))2:id())(4:Mext(((9:pos_fname15:malloc_some.smu)(8:pos_lnum2:11)(7:pos_bol3:125)(8:pos_cnum3:126))((9:pos_fname15:malloc_some.smu)(8:pos_lnum2:11)(7:pos_bol3:125)(8:pos_cnum3:141)))(6:Tarray4:Tint)((4:user5:vtest)(4:call(17:malloc_some_vtest)))5:false)(4:Mext(((9:pos_fname15:malloc_some.smu)(8:pos_lnum2:12)(7:pos_bol3:143)(8:pos_cnum3:144))((9:pos_fname15:malloc_some.smu)(8:pos_lnum2:12)(7:pos_bol3:143)(8:pos_cnum3:158)))(6:Tarray4:Tint)((4:user6:vtest2)(4:call(18:malloc_some_vtest2)))5:false))()) $ schmu use_malloc_some.smu --dump-llvm use_malloc_some.smu:3:7: warning: Unused binding do_something diff --git a/test/typing.ml b/test/typing.ml index c115f6ac..3eb64c61 100644 --- a/test/typing.ml +++ b/test/typing.ml @@ -791,6 +791,24 @@ let test_excl_parts_return_whole () = test_exn "a.a was moved in line 4, cannot use" (typ ^ "(defn meh [a!]\n (def c& !a.a)\n a)") +let test_excl_lambda_copy_capture () = + test "unit" "(defn alt [alts] (fn :copy alts () (ignore alts.[0])))" + +let test_excl_lambda_copy_capture_nonalloc () = + test "unit" "(defn alt [alts] (fn :copy alts () (ignore (+ 1 alts))))" + +let test_excl_lambda_not_copy_capture () = + test_exn "Borrowed parameter alts is moved" + "(defn alt [alts] (fn () (ignore alts.[0])))" + +let test_excl_fn_copy_capture () = + test "unit" + "(defn alt (alts) (defn named :copy alts () (ignore alts.[0])) named)" + +let test_excl_fn_not_copy_capture () = + test_exn "Borrowed parameter alts is moved" + "(defn alt (alts) (defn named () (ignore alts.[0])) named)" + let test_type_decl_not_unique () = test_exn "Type names in a module must be unique. t exists already" "(type t int) (type t float)" @@ -1380,6 +1398,12 @@ let () = (set &sm.slots.[slot-idx] !{:idx :gen nextgen}) (set &sm.free-hd !free-hd) (ignore {:gen nextgen :idx slot-idx}))|}; + case "lambda copy capture" test_excl_lambda_copy_capture; + case "lambda copy capture nonalloc" + test_excl_lambda_copy_capture_nonalloc; + case "lambda not copy capture" test_excl_lambda_not_copy_capture; + case "fn copy capture" test_excl_fn_copy_capture; + case "fn not copy capture" test_excl_fn_not_copy_capture; ] ); ( "type decl", [