Signed-off-by: Matthias Görgens <[email protected]>
mlvm/allocator.ml | 211 ++++++++++++++++++++++++++++++++-------------------- 1 files changed, 129 insertions(+), 82 deletions(-)
# HG changeset patch # User Matthias Görgens <[email protected]> # Date 1265652437 0 # Node ID e4653f775be2883d26dab52534cc15d1d48c4d7d # Parent 35e60cbfd1ad9ea6bde371ae1da2a6e8e389a1f0 mlvm-refactor: allocator (first part) changed to applicative style Signed-off-by: Matthias Görgens <[email protected]> diff -r 35e60cbfd1ad -r e4653f775be2 mlvm/allocator.ml --- 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_size (_,(_,s)) = s -let get_start (_,(s,_)) = s -let get_name (n,(_,_)) = n +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 make_area name start size = (name,(start,size)) +let get_end a = Int64.add (get_start a) (get_size a) -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 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) -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,(x...@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) +(* 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 rec setify = function - | [] -> [] - | (x::xs) -> if List.mem x xs then setify xs else x::(setify xs) +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 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 combine : t -> t -> t = (* does not guarantee normalization *) + fun t1 t2 -> + t1 @ t2 - 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 +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) + +(* 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 ", "
_______________________________________________ xen-api mailing list [email protected] http://lists.xensource.com/mailman/listinfo/xen-api
