Track warnings across projections

lib/typing/env.ml

@@ -115,7 +115,7 @@ type t = {
 }
 
 type warn_kind = Unused | Unmutated | Unused_mod
-type unused = (unit, (Path.t * warn_kind * Ast.loc) list) result
+type unused = (Path.t * warn_kind * Ast.loc) list
 
 let def_value env =
   {
@@ -362,19 +362,13 @@ let rec is_module_used modules =
             | _ -> failwith "unreachable"))
     modules false
 
-let sort_unused = function
-  | [] -> Ok ()
-  | some ->
-      (* Sort the warnings so the ones form the start of file are printed first *)
-      let s =
-        List.sort
-          (fun (_, _, ((lhs : Lexing.position), _)) (_, _, (rhs, _)) ->
-            if lhs.pos_lnum <> rhs.pos_lnum then
-              Int.compare lhs.pos_lnum rhs.pos_lnum
-            else Int.compare lhs.pos_cnum rhs.pos_cnum)
-          some
-      in
-      Error s
+let sort_unused unused =
+  (* Sort the warnings so the ones form the start of file are printed first *)
+  List.sort
+    (fun (_, _, ((lhs : Lexing.position), _)) (_, _, (rhs, _)) ->
+      if lhs.pos_lnum <> rhs.pos_lnum then Int.compare lhs.pos_lnum rhs.pos_lnum
+      else Int.compare lhs.pos_cnum rhs.pos_cnum)
+    unused
 
 let close_thing is_same modpath env =
   (* Close scopes up to next function scope *)

lib/typing/env.mli

@@ -15,7 +15,7 @@ type value = {
 
 type warn_kind = Unused | Unmutated | Unused_mod
 
-type unused = (unit, (Path.t * warn_kind * Ast.loc) list) result
+type unused = (Path.t * warn_kind * Ast.loc) list
 
 and touched = {
   tname : string;

lib/typing/exclusivity.ml

@@ -161,6 +161,7 @@ let borrow_state = ref 0
 let param_pass = ref false
 let shadowmap = ref Smap.empty
 let array_bindings = ref Idset.empty
+let mutables = ref Map.empty
 let is_string = function Sp_string -> true | Sp_no | Sp_array_get -> false
 
 let new_id str mname =
@@ -182,7 +183,8 @@ let reset () =
   borrow_state := 0;
   param_pass := false;
   shadowmap := Smap.empty;
-  array_bindings := Idset.empty
+  array_bindings := Idset.empty;
+  mutables := Map.empty
 
 let forbid_conditional_borrow loc imm mut =
   let msg =
@@ -484,6 +486,32 @@ let get_repr_ord ~borrows repr =
       Hashtbl.replace borrows repr ctr;
       ctr
 
+let mark_mutated env_item =
+  let rec mark_mutated id =
+    match Map.find_opt id !mutables with
+    | Some parent ->
+        (match parent with Some p, _ -> mark_mutated p | None, _ -> ());
+        mutables := Map.remove id !mutables
+    | None ->
+        (* It has already been marked as mutated. Nothing more to do *)
+        ()
+  in
+
+  match env_item.imm with
+  | [] -> ()
+  | [ Borrow_mut (b, _) ] -> mark_mutated b.repr
+  | _ ->
+      print_endline (show_env_item env_item);
+      failwith "Internal Error: What happened here?"
+
+let check_mutated () =
+  Map.fold
+    (fun _ (_, loc) acc ->
+      (* Mutated bindings have been removed. All remaining ones have not been mutated. *)
+      loc :: acc)
+    !mutables []
+  |> List.rev
+
 let get_moved_in_set env_item hist =
   let rec usage b = function
     | [ (Bown _ | Borrow _) ] -> Snot_moved
@@ -708,6 +736,7 @@ let rec check_tree env mut ((bpart, special) as bdata) tree hist =
       (* Track usage of values, but not the one being mutated *)
       let thing, t, hs = check_tree env Uset no_bdata thing hs in
       let moved = get_moved_in_set t hs in
+      mark_mutated t;
       let expr = Set (thing, value, moved) in
       ({ tree with expr }, t, add_hist t hs)
   | Sequence (fst, snd) ->
@@ -939,16 +968,21 @@ and check_let ~tl loc env id rhs rmut pass hist =
              ( rhs.loc,
                "Specify how rhs expression is passed. Either by move '!' or \
                 mutably '&'" ))
-    | Bmove _ as b -> (Bown (id, Hashtbl.create 32), add_hist (imm [ b ]) hs)
+    | Bmove _ as b ->
+        if rhs.attr.mut then mutables := Map.add id (None, loc) !mutables;
+        (Bown (id, Hashtbl.create 32), add_hist (imm [ b ]) hs)
     | (Borrow _ | Borrow_mut _) when tlborrow ->
         raise (Error (rhs.loc, "Cannot borrow mutable binding at top level"))
     | Borrow b -> (Borrow { b with loc; ord = neword () }, hs)
-    | Borrow_mut (b, s) -> (Borrow_mut ({ b with loc; ord = neword () }, s), hs)
+    | Borrow_mut (b, s) ->
+        mutables := Map.add id (Some b.repr, loc) !mutables;
+        (Borrow_mut ({ b with loc; ord = neword () }, s), hs)
     | Bown _ -> failwith "Internal Error: A borrowed thing isn't owned"
   in
   let imm, hs =
     match rval.imm with
     | [] ->
+        if rhs.attr.mut then mutables := Map.add id (None, loc) !mutables;
         (* No borrow, original, owned value *)
         ([ Bown (id, Hashtbl.create 32) ], hs)
     | b ->
@@ -1108,18 +1142,22 @@ let check_tree ~mname pts pns touched body =
   (* parameters *)
   let i = ref 0 in
   let env, hist =
-    List.fold_left
-      (fun (map, hs) (n, _) ->
+    List.fold_left2
+      (fun (map, hs) p (n, loc) ->
         (* 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)));
+        (* Register mutable variables *)
+        (match p.pattr with
+        | Dmut -> mutables := Map.add id (None, loc) !mutables
+        | _ -> ());
         let b = [ Bown (id, List.nth param_borrows !i) ] in
         incr i;
         (Map.add id (imm b) map, add_hist (imm b) hs))
-      (env, hist) pns
+      (env, hist) pts pns
   in
 
   (* [Umove] because we want to move return values *)
@@ -1159,7 +1197,7 @@ let check_tree ~mname pts pns touched body =
         { t with tattr; tattr_loc })
       touched
   in
-  (touched, body)
+  (check_mutated (), touched, body)
 
 let check_items ~mname touched items =
   reset ();
@@ -1179,6 +1217,8 @@ let check_items ~mname touched items =
     List.fold_left_map check_item (env, false, Usage.Uread, [], hist) items
   in
 
+  let unmutated = check_mutated () in
+
   check_array_moves hist;
   (* No moves at top level *)
   Map.iter
@@ -1206,4 +1246,4 @@ let check_items ~mname touched items =
       | Dset | Dmut | Dnorm -> ())
     touched;
 
-  items
+  (unmutated, items)

lib/typing/typing.ml

@@ -68,21 +68,35 @@ let check_annot env loc l r =
 let main_path = Path.Pid "schmu"
 let is_module = function Path.Pid "schmu" -> false | Pid _ | Pmod _ -> true
 
-let check_unused env = function
-  | Ok () -> ()
-  | Error errors ->
-      let err (name, kind, loc) =
-        let warn_kind =
-          match kind with
-          | Env.Unused -> "Unused binding "
-          | Unmutated -> "Unmutated mutable binding "
-          | Unused_mod -> "Unused module import "
-        in
-        (Option.get !fmt_msg_fn) "warning" loc
-          (warn_kind ^ Path.(rm_name (Env.modpath env) name |> show))
-        |> print_endline
-      in
-      List.iter err errors
+let loc_equal (af, asnd) (bf, bsnd) =
+  let open Lexing in
+  String.equal af.pos_fname bf.pos_fname
+  && Int.equal af.pos_lnum bf.pos_lnum
+  && Int.equal af.pos_cnum bf.pos_cnum
+  && Int.equal asnd.pos_cnum bsnd.pos_cnum
+
+let check_unused env unused unmutated =
+  let err (name, kind, loc) =
+    let warn_kind =
+      match kind with
+      | Env.Unused -> "Unused binding "
+      | Unmutated -> "Unmutated mutable binding "
+      | Unused_mod -> "Unused module import "
+    in
+
+    (* We need to use the location to match the errors because the two systems
+       deal with shadowing in a different way *)
+    let print =
+      match kind with
+      | Env.Unmutated -> List.exists (fun l -> loc_equal l loc) unmutated
+      | Unused | Unused_mod -> true
+    in
+    if print then
+      (Option.get !fmt_msg_fn) "warning" loc
+        (warn_kind ^ Path.(rm_name (Env.modpath env) name |> show))
+      |> print_endline
+  in
+  List.iter err unused
 
 let string_of_bop = function
   | Ast.Plus_i -> "+"
@@ -917,7 +931,7 @@ end = struct
     leave_level ();
     let _, closed_vars, touched, unused = Env.close_function env in
 
-    let touched, body =
+    let unmutated, touched, body =
       Exclusivity.check_tree params_t ~mname:(Env.modpath env)
         (List.map2 (fun n (d : Ast.decl) -> (n, d.loc)) nparams params)
         touched body
@@ -946,7 +960,7 @@ end = struct
     in
 
     let kind = match closed_vars with [] -> Simple | lst -> Closure lst in
-    check_unused env unused;
+    check_unused env unused unmutated;
 
     (* For codegen: Mark functions in parameters closures *)
     let params_t =
@@ -1017,7 +1031,7 @@ end = struct
 
     let env, closed_vars, touched, unused = Env.close_function env in
 
-    let touched, body =
+    let unmutated, touched, body =
       Exclusivity.check_tree params_t ~mname:(Env.modpath env)
         (List.map2 (fun n (d : Ast.decl) -> (n, d.loc)) nparams params)
         touched body
@@ -1047,7 +1061,7 @@ end = struct
     in
 
     let kind = match closed_vars with [] -> Simple | lst -> Closure lst in
-    check_unused env unused;
+    check_unused env unused unmutated;
 
     (* For codegen: Mark functions in parameters closures *)
     let params_t =
@@ -1608,11 +1622,12 @@ let rec convert_module env mname sign prog check_ret =
   List.iter (catch_weak_vars env) items;
 
   let _, _, touched, unused = Env.close_toplevel env in
+
+  let unmutated, items = Exclusivity.check_items ~mname touched items in
+
   let has_sign = match sign with [] -> false | _ -> true in
   if (not (is_module (Env.modpath env))) || has_sign then
-    check_unused env unused;
-
-  let items = Exclusivity.check_items ~mname touched items in
+    check_unused env unused unmutated;
 
   (* Program must evaluate to either int or unit *)
   (if check_ret then

test/misc.t/run.t

@@ -4067,11 +4067,6 @@ Check allocs in fixed array
   1 | (def arr #[#[1 2 3] #[3 4 5]])
            ^^^
 
-  fixed_array_allocs.smu:8.6-9: warning: Unmutated mutable binding arr.
-
-  8 | (def arr& #["hey" "hie"]) -- correctly free as mut
-           ^^^
-
   $ valgrind -q --leak-check=yes --show-reachable=yes ./fixed_array_allocs
   3
   hi

test/mutable_value_semantics.t/projection_warnings.smu

@@ -0,0 +1,10 @@
+(let ((x& [0])
+      (y& &x)
+      (z& &y))
+  (def w& &y)
+  (def ii& &w)
+  (set &ii ![2]))
+
+(defn testfn (a& [b& int])
+  (let ((c& &a))
+    (set &c !123)))

test/mutable_value_semantics.t/run.t

@@ -207,21 +207,11 @@ Test simple setting of mutable variables
 
 Warn on unneeded mutable bindings
   $ schmu unneeded_mut.smu
-  unneeded_mut.smu:1.19-20: warning: Unmutated mutable binding a.
-
-  1 | (defn do_nothing (a&)
-                        ^
-
   unneeded_mut.smu:1.7-17: warning: Unused binding do_nothing.
 
   1 | (defn do_nothing (a&)
             ^^^^^^^^^^
 
-  unneeded_mut.smu:7.6-7: warning: Unmutated mutable binding b.
-
-  7 | (def b& 0)
-           ^
-
 Use mutable values as ptrs to C code
   $ schmu -c --dump-llvm ptr_to_c.smu
   ; ModuleID = 'context'
@@ -1373,11 +1363,6 @@ Convert Const_ptr values to Ptr in copy
 
 Fix codegen
   $ schmu --dump-llvm codegen_nested_projections.smu
-  codegen_nested_projections.smu:2.8-9: warning: Unmutated mutable binding x.
-
-  2 |   (def x& 10)
-             ^
-
   codegen_nested_projections.smu:4.8-9: warning: Unused binding z.
 
   4 |   (def z& &y)
@@ -1412,3 +1397,21 @@ Partial move parameter
 Partial move set
   $ schmu partial_move_set.smu
   $ valgrind -q --leak-check=yes --show-reachable=yes ./partial_move_set
+
+Track unmutated binding warnings across projections
+  $ schmu projection_warnings.smu
+  projection_warnings.smu:8.19-20: warning: Unused binding b.
+
+  8 | (defn testfn (a& [b& int])
+                        ^
+
+  projection_warnings.smu:3.8-9: warning: Unused binding z.
+
+  3 |       (z& &y))
+             ^
+
+  projection_warnings.smu:8.7-13: warning: Unused binding testfn.
+
+  8 | (defn testfn (a& [b& int])
+            ^^^^^^
+