mlvm-refactor: allocator (first part) changed to applicative style

Signed-off-by: Matthias Goergens <matthias.goergens@citrix.com>

diff --git a/mlvm/allocator.ml b/mlvm/allocator.ml
index 6a53632e52201277b360af64ba5d13b1601f26ff..77b81130d5ec52c149f28dcfe594a00c74101e23 100644 (file)
--- a/mlvm/allocator.ml
+++ b/mlvm/allocator.ml
@@ -1,94 +1,141 @@
-type t = (string * (int64 * int64)) list with rpc
+open Pervasiveext
+open Listext
+
+(* Sparse allocation should be fast. Expanding memory should be fast, for a bunch of volumes. *)
+
+type area = (string * (int64 * int64)) with rpc
+type t = area list with rpc
 
 let create name size = [(name,(0L,size))]
+let empty = []
+
+let get_name (name,(_,_)) = name
+let get_start (_,(start,_)) = start
+let get_size (_,(_,size)) = size
+let unpack_area (pv_name, (start,size)) = (pv_name, (start,size))
+
+let get_end a = Int64.add (get_start a) (get_size a)
+
+let make_area pv_name start size = (pv_name, (start,size))
+let make_area_by_end name start endAr = make_area name start (Int64.sub endAr start)
+
+(* Define operations on areas, and then use those to build the
+   allocation algorithms.  That should make it easier to test, and the
+   algorithms are easier to read without arithmetic in them.
+*)
+
+let intersect : area -> area -> area list = 
+    fun a a2 ->
+       let (name, (start, size)) = unpack_area a in
+       let (name2, (start2, size2)) = unpack_area a2 in
+       let enda = get_end a in
+       let enda2 = get_end a2 in
+       let startI = max start start2 in
+       let endI = min enda enda2 in
+       let sizeI = max Int64.zero (Int64.sub endI startI) in
+       if name = name2 
+       then make_area name (max start start2) (max Int64.zero sizeI) :: []
+       else []
+
+let combine : t -> t -> t = (* does not guarantee normalization *)
+    fun t1 t2 ->
+       t1 @ t2 
+
+let union : area -> area -> t = (* does not guarantee normalization *)
+    fun a a2 ->
+       a::a2::[]
+let minus : area -> area -> t = (* does not guarantee normalization *)
+    fun a a2 ->
+       let (name, (start, size)) = unpack_area a in
+       let (name2, (start2, size2)) = unpack_area a2 in
+       let enda = get_end a in
+       let enda2 = get_end a2 in
+        if name = name2
+       then List.filter ((<) Int64.zero ++ get_size) ++ List.fold_left combine [] ++ List.map (intersect a ++ Fun.uncurry (make_area_by_end name2)) $ ((start, start2) :: (enda2, enda)::[])
+       else a :: []
+
+(* Is a contained in a2? *)
+let contained : area -> area -> bool =
+    fun a a2 ->
+       let (name, (start, size)) = unpack_area a in
+       let (name2, (start2, size2)) = unpack_area a2 in
+       (* (* This would only check if `a' starts within `a2': *)
+          name=name2 && start >= start2 && start < Int64.add size2 start2
+       *)
+       name=name2 && start >= start2 && Int64.add start size <= Int64.add start2 size2
+
+exception PVS_DONT_MATCH
+
+(* assumes all areas stem from the same pv *)
+let normalize_single_pv areas =
+    (* Underlying structure for merge1: foldM merge1 (for a1) on WriterMonad (for acc) over segs *)
+    (* The type of the accumulator here is a bit ugly.  Perhaps a real non-empty list would be better? *)
+    let merge1 (a1, acc) a2 =
+       let (name, (start1, size1)) = unpack_area a1
+       and (name2, (start2, size2)) = unpack_area a2 in
+       if (name != name2) then raise PVS_DONT_MATCH
+       else if (Int64.add start1 size1) = start2 then
+           (make_area name start1 (Int64.add size1 size2), acc)
+       else
+           (a2, List.cons a1 acc) in
+    (function
+        | start::segs -> 
+              (Fun.uncurry List.cons) $ List.fold_left merge1 (start, []) segs
+        | [] -> [] (* shouldn't be necessary! *))
+    ++ List.sort (Fun.on compare get_start) $ areas
+let normalize : t -> t = 
+    fun areas ->
+    (* The next lines are to be read backwards, since we defined function composition that way. *)
+
+    let module StringMap = Mapext.Make (String) in
+    (* put free areas of all PVs back together *)
+    List.flatten ++ StringMap.values
+       (* normalize each pv's areas *)
+    ++ StringMap.map normalize_single_pv
+       (* separate by pv *)
+    ++ StringMap.fromListWith List.append ++ List.map (fun seg -> (get_name seg, [seg]))
+       $ areas
+
+(* Which invariants does t have to satisfy?  Which invariants does our
+   result here satisfy?
+
+   E.g. is it possible for areas to overlap or contain each other?  If not, should we warn if they do?
+
+   t is a free list.
+
+   What if there's no containing area? Is this only called under certain circumstances? Verify. *)
+let alloc_specified_area (free_list : t) (a : area) =
+    (* We assume areas don't overlap, or do we? *)
+    (* Match against [] instead of _: Better die as soon as possible, when something is wrong. *)
+    let (containing_area::[]),other_areas = List.partition (contained a) $ free_list in
+
+    normalize $ combine (minus containing_area a) other_areas
+
+let alloc_specified_areas : t -> t -> t =
+   List.fold_left alloc_specified_area
+
+let alloc (free_list : t) (newsize : int64) =
+    (* switched from best-fit (smallest free area that's large
+       enough) to worst-fit (largest area): This may reduce
+       fragmentation, and makes the code slightly easier. *)
+    let rec alloc_h newsize = function
+       | (seg::rest) -> 
+             let remainder = Int64.sub newsize (get_size seg) in
+             if (remainder > Int64.zero) then
+                  (* We couldn't find one contiguous region to allocate. Call alloc again
+                    with the remainder of the size and the new list of allocated areas *)
+                  let allocd,newt = alloc_h remainder rest in
+                  (seg::allocd, newt)
+             else
+                  let (name, (start, _)) = unpack_area seg in
+                  let area = make_area name start newsize in
+                  ([area], alloc_specified_area (seg::rest) area)
+       | [] -> failwith "Failed to find individual area!" in
+    (alloc_h newsize
+     ++ List.rev ++ List.sort (Fun.on compare get_size) $ free_list)
 
-let get_size (_,(_,s)) = s
-let get_start (_,(s,_)) = s
-let get_name (n,(_,_)) = n
-
-let make_area name start size = (name,(start,size))
-
-let alloc_specified_area (t : t) a =
-  let size = get_size a in
-  let start = get_start a in
-  let name = get_name a in
-  let test a2 = 
-    let size2 = get_size a2 in
-    let start2 = get_start a2 in
-    let name2 = get_name a2 in
-    name=name2 && start >= start2 && start < Int64.add size2 start2 
-  in
-  let containing_areas,other_areas = List.partition test t in
-  let containing_area = List.hd containing_areas in
-  let ca_start = get_start containing_area in
-  let ca_size = get_size containing_area in
-  let ca_name = get_name containing_area in
-  let new_areas = 
-    if start=ca_start then other_areas else (make_area ca_name ca_start (Int64.sub start ca_start))::other_areas
-  in
-  let new_areas =
-    if (Int64.add start size) = (Int64.add ca_start ca_size) 
-    then new_areas 
-    else (make_area ca_name (Int64.add start size) (Int64.sub (Int64.add ca_start ca_size) (Int64.add start size)))::new_areas
-  in
-  new_areas
-
-let alloc_specified_areas =
-  List.fold_left alloc_specified_area
-  
-let rec alloc t newsize = 
-  let l = List.sort (fun a1 a2 -> compare (get_size a1) (get_size a2)) t in
-  let rec find xs ys =
-    match ys with
-      | seg::[] ->
-         (* If there's only one segment left, it's the largest. Allocate. *)
-         seg,xs
-      |        seg::rest -> 
-         let size = get_size seg in
-         if size >= newsize 
-         then seg,(xs@rest)
-         else find (seg::xs) rest
-      | _ -> failwith "Failed to find individual segment!"
-  in
-  let seg,rest = find [] l in
-  let size = get_size seg in
-  if (size < newsize) then
-    (* We couldn't find one contiguous region to allocate. Call alloc again
-       with the remainder of the size and the new list of allocated segments *)
-    let allocd,newt = alloc (rest) (Int64.sub newsize size) in
-    (seg::allocd, newt)
-  else
-    let name = get_name seg in
-    let start = get_start seg in
-    let area = make_area name start newsize in
-    ([area], alloc_specified_area t area)
-
-let rec setify = function
-        | [] -> []
-        | (x::xs) -> if List.mem x xs then setify xs else x::(setify xs)
-
-let free t segs =
-  let l = List.sort (fun a1 a2 -> compare (get_start a1) (get_start a2)) (t@segs) in
-  let pvs = List.map get_name l in
-  let pvs = setify pvs in
-
-  let rec test acc segs =
-    match segs with
-      | a1::a2::rest ->
-         let start1 = get_start a1 in
-         let size1 = get_size a1 in
-         let start2 = get_start a2 in
-         let size2 = get_size a2 in
-         let name = get_name a1 in
-         if (Int64.add start1 size1) = start2 then
-           test acc ((make_area name start1 (Int64.add size1 size2))::rest)
-         else
-           test ((List.hd segs)::acc) (List.tl segs)
-      | [x] -> x::acc
-      | [] -> acc (* shouldn't be necessary! *)
-  in
-  
-  List.fold_left (fun acc pv -> test acc (List.filter (fun seg -> get_name seg = pv) l)) [] pvs
+(* Probably de-allocation won't be used much. *)
+let free to_free free_list = normalize (combine to_free free_list)
 
 let to_string t =
   String.concat ", "