# HG changeset patch
# User Matthias Görgens <matthias.goergens@xxxxxxxxxx>
# Date 1265127713 0
# Node ID 879a90ce45dde424b416a0e68d4c4e3f90ce1734
# Parent  452da349aea2e41bcfb19af353850c542eaa799c
Makes the allocator more robust by enabling allocation of 0 bytes.

`normalize' and `alloc_specified_area' no longer get confused by 0 byte allocations.

Signed-off-by: Matthias Goergens <matthias.goergens@xxxxxxxxxx> (Mercurial doesn't like Umlaute.)

diff -r 452da349aea2 -r 879a90ce45dd mlvm/allocator.ml
--- a/mlvm/allocator.ml
+++ b/mlvm/allocator.ml
@@ -6,6 +6,11 @@
 type area = (string * (int64 * int64)) with rpc
 type t = area list with rpc
 
+let to_string1 (p,(s,l)) = Printf.sprintf "(%s: [%Ld,%Ld])" p s l
+let to_string t =
+  String.concat ", "
+    (List.map to_string1 t)
+
 let create name size = [(name,(0L,size))]
 let empty = []
 
@@ -59,9 +64,6 @@
     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
@@ -82,7 +84,7 @@
 	 | start::segs -> 
 	       (Fun.uncurry List.cons) $ List.fold_left merge1 (start, []) segs
 	 | [] -> [] (* shouldn't be necessary! *))
-    ++ List.sort (Fun.on compare get_start) $ areas
+    ++ List.sort (Fun.on compare get_start) ++ List.filter ((<) 0L ++ get_size) $ areas
 let normalize : t -> t = 
     fun areas ->
     (* The next lines are to be read backwards, since we defined function composition that way. *)
@@ -104,43 +106,49 @@
    t is a free list.
 
    What if there's no containing area? Is this only called under certain circumstances? Verify. *)
+exception NonSingular_Containing_Area
 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
+    (* Match against [] instead of _: Better die as soon as possible, when something is wrong. 
+     * And that was right!  Just caught a bug that would have been masked otherwise. *)
+    match List.partition (contained a) ++ normalize $ free_list with
+	| (containing_area::[]), other_areas -> normalize $ combine (minus containing_area a) other_areas
+	| x,_ -> (print_string "alloc_specified_area:\t";
+		  print_endline ++ to_string $ x;
+		  raise NonSingular_Containing_Area;)
 
 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 safe_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 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 *)
+		match alloc_h remainder rest with
+		    | Some (allocd,newt) -> Some (seg::allocd, newt)
+		    | None -> None
+	    else
+                let (name, (start, _)) = unpack_area seg in
+                let area = make_area name start newsize in
+                Some ([area], try (alloc_specified_area (seg::rest) area) with (Match_failure x) -> (print_endline "alloc_specified_area"; raise (Match_failure x)))
+	| [] -> None in
+    alloc_h newsize
+    ++ List.rev ++ List.sort (Fun.on compare get_size) $ free_list
+      
+let alloc (free_list : t) (newsize : int64) =
+    match safe_alloc free_list newsize
+    with  Some x -> x
+	| None -> failwith "Failed to find individual area!"
 
 (* 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 ", "
-    (List.map (fun (p,(s,l)) -> Printf.sprintf "(%s: [%Ld,%Ld])" p s l) t)
-
 let dotest a n =
     let before = List.sort compare a in
     let (alloced,after)=alloc a n in