Merge pull request #175 from OCamlPro-Iguernlala/simple-sharing-Maps

Simple sharing maps

Changes

@@ -146,7 +146,10 @@ Standard library:
   (Christopher McAlpine)
 - PR#6645, GPR#174: Guarantee that Set.add, Set.remove, Set.filter
   return the original set if no change is required (Alain Frisch,
-  Mohamed Iguernelala)
+  Mohamed Iguernlala)
+- GPR#175: Guarantee that Map.add, Map.remove, Map.filter
+  return the original map if no change is required.
+  (Mohamed Iguernlala)
 - PR#6694, PR#6695: deprecate functions using ISO-8859-1 character set
   in Char, Bytes, String and provide alternatives using US-ASCII.
   (Peter Zotov)

stdlib/map.ml

@@ -103,14 +103,16 @@ module Make(Ord: OrderedType) = struct
     let rec add x data = function
         Empty ->
           Node(Empty, x, data, Empty, 1)
-      | Node(l, v, d, r, h) ->
+      | Node(l, v, d, r, h) as m ->
           let c = Ord.compare x v in
           if c = 0 then
-            Node(l, x, data, r, h)
+            if d == data then m else Node(l, x, data, r, h)
           else if c < 0 then
-            bal (add x data l) v d r
+            let ll = add x data l in
+            if l == ll then m else bal ll v d r
           else
-            bal l v d (add x data r)
+            let rr = add x data r in
+            if r == rr then m else bal l v d rr
 
     let rec find x = function
         Empty ->
@@ -153,14 +155,13 @@ module Make(Ord: OrderedType) = struct
     let rec remove x = function
         Empty ->
           Empty
-      | Node(l, v, d, r, h) ->
+      | (Node(l, v, d, r, h) as t) ->
           let c = Ord.compare x v in
-          if c = 0 then
-            merge l r
+          if c = 0 then merge l r
           else if c < 0 then
-            bal (remove x l) v d r
+            let ll = remove x l in if l == ll then t else bal ll v d r
           else
-            bal l v d (remove x r)
+            let rr = remove x r in if r == rr then t else bal l v d rr
 
     let rec iter f = function
         Empty -> ()
@@ -271,12 +272,13 @@ module Make(Ord: OrderedType) = struct
 
     let rec filter p = function
         Empty -> Empty
-      | Node(l, v, d, r, _) ->
+      | Node(l, v, d, r, _) as t ->
           (* call [p] in the expected left-to-right order *)
           let l' = filter p l in
           let pvd = p v d in
           let r' = filter p r in
-          if pvd then join l' v d r' else concat l' r'
+          if pvd then if l==l' && r==r' then t else join l' v d r'
+          else concat l' r'
 
     let rec partition p = function
         Empty -> (Empty, Empty)

stdlib/map.mli

@@ -77,7 +77,11 @@ module type S =
     val add: key -> 'a -> 'a t -> 'a t
     (** [add x y m] returns a map containing the same bindings as
        [m], plus a binding of [x] to [y]. If [x] was already bound
-       in [m], its previous binding disappears. *)
+       in [m] to a value that is physically equal to [y],
+       [m] is returned unchanged (the result of the function is
+       then physically equal to [m]). Otherwise, the previous binding
+       of [x] in [m] disappears.
+       @before 4.03 Physical equality was not ensured. *)
 
     val singleton: key -> 'a -> 'a t
     (** [singleton x y] returns the one-element map that contains a binding [y]
@@ -87,7 +91,10 @@ module type S =
 
     val remove: key -> 'a t -> 'a t
     (** [remove x m] returns a map containing the same bindings as
-       [m], except for [x] which is unbound in the returned map. *)
+       [m], except for [x] which is unbound in the returned map.
+       If [x] was not in [m], [m] is returned unchanged
+       (the result of the function is then physically equal to [m]).
+       @before 4.03 Physical equality was not ensured. *)
 
     val merge:
          (key -> 'a option -> 'b option -> 'c option) -> 'a t -> 'b t -> 'c t
@@ -132,8 +139,11 @@ module type S =
 
     val filter: (key -> 'a -> bool) -> 'a t -> 'a t
     (** [filter p m] returns the map with all the bindings in [m]
-        that satisfy predicate [p].
+        that satisfy predicate [p]. If [p] satisfies every binding in [m],
+        [m] is returned unchanged (the result of the function is then
+        physically equal to [m])
         @since 3.12.0
+       @before 4.03 Physical equality was not ensured.
      *)
 
     val partition: (key -> 'a -> bool) -> 'a t -> 'a t * 'a t

testsuite/tests/lib-set/testmap.ml

@@ -132,3 +132,53 @@ let rmap() =
 let _ =
   Random.init 42;
   for i = 1 to 10000 do test (rkey()) (rdata()) (rmap()) (rmap()) done
+
+let () =
+  (* check that removing a binding from a map that is not present in this map
+     (1) doesn't allocate and (2) return the original map *)
+  let m1 = ref M.empty in
+  for i = 1 to 10 do m1 := M.add i (float i) !m1 done;
+  let m2 = ref !m1 in
+
+  let a0 = Gc.allocated_bytes () in
+  let a1 = Gc.allocated_bytes () in
+  for i = 11 to 30 do m2 := M.remove i !m2 done;
+  let a2 = Gc.allocated_bytes () in
+
+  assert (!m2 == !m1);
+  assert(a2 -. a1 = a1 -. a0)
+
+let () =
+  (* check that filtering a map where all bindings are satisfied by
+     the given predicate returns the original map *)
+  let m1 = ref M.empty in
+  for i = 1 to 10 do m1 := M.add i (float i) !m1 done;
+  let m2 = M.filter (fun e _ -> e >= 0) !m1 in
+  assert (m2 == !m1)
+
+let () =
+  (* check that adding a binding "x -> y" to a map that already
+     contains it doesn't allocate and return the original map. *)
+  let m1 = ref M.empty in
+  let tmp = ref None in
+  for i = 1 to 10 do
+    tmp := Some (float i);
+    m1 := M.add i !tmp !m1
+  done;
+  let m2 = ref !m1 in
+
+  let a0 = Gc.allocated_bytes () in
+  let a1 = Gc.allocated_bytes () in
+
+  (* 10 |-> !tmp is already present in !m2 *)
+  m2 := M.add 10 !tmp !m2;
+
+  let a2 = Gc.allocated_bytes () in
+
+  assert (!m2 == !m1);
+  assert(a2 -. a1 = a1 -. a0);
+
+  (* 4 |-> Some 84. is not present in !m2 *)
+  m2 := M.add 4 (Some 84.) !m2;
+
+  assert (not (!m2 == !m1));