Adding a bitset implementation to manage usage of disk space

src/bitset.ml

@@ -0,0 +1,224 @@
+module Make (B : Context.A_DISK) = struct
+  module Sector = Sector.Make (B)
+  module Schema = Schema.Make (B)
+
+  type t = Sector.t
+
+  open Lwt_result.Syntax
+
+  let get_page_size () = B.page_size
+
+  let get_nb_leaves () =
+    let nb_sectors = Int64.to_int B.nb_sectors in
+    let page_size = get_page_size () in
+    let bit_size = page_size * 8 in
+    (nb_sectors + bit_size - 1) / bit_size
+
+  let get_group_size nb_children nb_leaves =
+    let rec get_group_size group_size =
+      if group_size * nb_children >= nb_leaves
+      then group_size
+      else get_group_size (group_size * nb_children)
+    in
+    get_group_size 1
+
+  let get_ptr_size () =
+    let pointer_size = Sector.ptr_size in
+    let id_size = Sector.id_size in
+    ((pointer_size + id_size) / 8) + 8
+
+  let get_nb_children page_size =
+    let incr = get_ptr_size () in
+    (page_size - 4) / incr (* 4 bytes for the sector id*)
+
+  let get value offset = value land (1 lsl offset)
+
+  let get_flag t i =
+    let pos = i / 8 in
+    let* value = Sector.get_uint8 t pos in
+    let offset = i mod 8 in
+    let flag = get value offset in
+    Lwt_result.return flag
+
+  let get_leaf t i =
+    let page_size = get_page_size () in
+    let bit_size = page_size * 8 in
+    let leaf_ind = i / bit_size in
+    let nb_leaves = get_nb_leaves () in
+    let nb_children = get_nb_children page_size in
+    let incr = get_ptr_size () in
+    let rec reach_leaf t leaf_ind nb_leaves =
+      let group_size = get_group_size nb_children nb_leaves in
+      let child_ind = leaf_ind / group_size in
+      let new_leaves =
+        if child_ind = (nb_leaves - 1) / group_size
+        then ((nb_leaves - 1) mod group_size) + 1
+        else group_size
+      in
+      let* child = Sector.get_child t (incr * child_ind) in
+      if group_size = 1
+      then Lwt_result.return child
+      else reach_leaf child (leaf_ind mod group_size) new_leaves
+    in
+    reach_leaf t leaf_ind nb_leaves
+
+  let free_leaf t i =
+    let pos = i / 8 in
+    let* value = Sector.get_uint8 t pos in
+    let offset = i mod 8 in
+    let flag = value land (1 lsl offset) in
+    assert (flag > 0) ;
+    let update = value lxor (1 lsl offset) in
+    Sector.set_uint8 t pos update
+
+  let free t i =
+    let page_size = get_page_size () in
+    let bit_size = page_size * 8 in
+    let* leaf = get_leaf t i in
+    free_leaf leaf (i mod bit_size)
+
+  (* TODO: Optimize free_range to use less set_uint calls *)
+  let rec free_range t (id, len) =
+    if len = 0
+    then Lwt_result.return ()
+    else (
+      let int_id = Int64.to_int (B.Id.to_int64 id) in
+      let* () = free t int_id in
+      free_range t (B.Id.succ id, len - 1))
+
+  let use_leaf t i =
+    let pos = i / 8 in
+    let* value = Sector.get_uint8 t pos in
+    let offset = i mod 8 in
+    let flag = value land (1 lsl offset) in
+    assert (flag = 0) ;
+    let update = value lor (1 lsl offset) in
+    Sector.set_uint8 t pos update
+
+  let use t i =
+    let page_size = get_page_size () in
+    let bit_size = page_size * 8 in
+    let* leaf = get_leaf t i in
+    use_leaf leaf (i mod bit_size)
+
+  (* TODO: Optimize use_range to use less set_uint calls *)
+  let rec use_range t (id, len) =
+    if len = 0
+    then Lwt_result.return ()
+    else (
+      let int_id = Int64.to_int (B.Id.to_int64 id) in
+      let* () = use t int_id in
+      use_range t (B.Id.succ id, len - 1))
+
+  let create_leaf () =
+    let* t = Sector.create () in
+    let sz = B.page_size in
+    let rec init = function
+      | i when i >= sz -> Lwt_result.return ()
+      | i ->
+        let* () = Sector.set_uint8 t i 0 in
+        init (i + 1)
+    in
+    let+ () = init 0 in
+    t
+
+  let rec create_parent nb_leaves page_size =
+    let* parent = create_leaf () in
+    let incr = get_ptr_size () in
+    let nb_children = get_nb_children page_size in
+    let group_size = get_group_size nb_children nb_leaves in
+    if group_size = 1
+    then (
+      let rec init_leaves cur_index = function
+        | -1 -> Lwt_result.return ()
+        | nb_leaf ->
+          let* leaf = create_leaf () in
+          let* () = Sector.set_child parent cur_index leaf in
+          init_leaves (cur_index + incr) (nb_leaf - 1)
+      in
+      let+ () = init_leaves 0 (nb_leaves - 1) in
+      parent)
+    else (
+      let rec init_parent index = function
+        | 0 -> Lwt_result.return ()
+        | nb_leaves ->
+          let group = min nb_leaves group_size in
+          let* child = create_parent group page_size in
+          let* () = Sector.set_child parent index child in
+          init_parent (index + incr) (nb_leaves - group)
+      in
+      let+ () = init_parent 0 nb_leaves in
+      parent)
+
+  let create () =
+    let page_size = get_page_size () in
+    let nb_leaves = get_nb_leaves () in
+    let* root = create_parent nb_leaves page_size in
+    let rec init_res = function
+      | num when num < 0 -> Lwt_result.return ()
+      | num ->
+        let* () = use root num in
+        init_res (num - 1)
+    in
+    let+ () = init_res 12 in
+    root
+
+  let pop_front t quantity =
+    let page_size = get_page_size () in
+    let bit_size = page_size * 8 in
+    let nb_sectors = Int64.to_int B.nb_sectors in
+    let* start_ind = Sector.get_uint32 t (page_size - 4) in
+    let start_ind = start_ind - (start_ind mod 8) in
+    let rec do_pop_front ind lst leaf =
+      assert (List.length lst < quantity) ;
+      let pos = ind mod bit_size / 8 in
+      let* value = Sector.get_uint8 leaf pos in
+      let needed = quantity - List.length lst in
+      let rec get_id cur_ind needed lst =
+        if cur_ind >= nb_sectors || cur_ind = ind + 8 || needed = 0
+        then lst
+        else (
+          let flag = get value (cur_ind mod 8) in
+          if flag = 0
+          then get_id (cur_ind + 1) (needed - 1) (cur_ind :: lst)
+          else get_id (cur_ind + 1) needed lst)
+      in
+      let lst = get_id ind needed lst in
+      if List.length lst = quantity
+      then Lwt_result.return (List.nth lst 0 , lst)
+      else if ind < start_ind && ind + 8 >= start_ind
+      then (
+        Format.printf "wait %d %d %d@." ind start_ind quantity;
+        Lwt_result.fail `Disk_is_full)
+      else
+        let* leaf =
+          if ind / bit_size <> (ind + 8) / bit_size
+          then get_leaf t ind
+          else Lwt_result.return leaf
+        in
+        if ind + 8 >= nb_sectors
+        then do_pop_front 0 lst leaf
+        else do_pop_front (ind + 8) lst leaf
+    in
+    let* start_leaf = get_leaf t start_ind in
+    let* end_ind, lst = do_pop_front start_ind [] start_leaf in
+    let lst = List.rev lst in 
+    let* () =
+      if end_ind >= nb_sectors
+      then Sector.set_uint32 t (page_size - 4) 0
+      else Sector.set_uint32 t (page_size - 4) end_ind
+    in
+    let rec get_range_list cur = function
+      | id :: res ->
+        (match cur with
+         | (top, range) :: rest_cur ->
+           if top + range = id
+           then get_range_list ((top, range + 1) :: rest_cur) res
+           else get_range_list ((id, 1) :: cur) res
+         | [] -> get_range_list [ id, 1 ] res)
+      | [] -> cur
+    in
+    let lst = get_range_list [] lst in
+    let lst = List.map (fun (id, range) -> B.Id.of_int id, range) lst in
+    Lwt_result.return lst
+end

src/fs.ml

@@ -85,7 +85,7 @@ module Make_disk (Clock : Mirage_clock.PCLOCK) (B : Context.A_DISK) :
       else Files.reachable_size t.files
     in
     let+ queue =
-      let* _, root_queue, _ = Root.get_free_queue t.root in
+      let* _, root_queue, _,  _ = Root.get_free_queue t.root in
       if Sector.is_null_ptr root_queue
       then Lwt_result.return 0
       else Queue.reachable_size t.free_queue

src/queue.ml

@@ -1,6 +1,7 @@
 module Make (B : Context.A_DISK) = struct
   module Sector = Sector.Make (B)
   module Schema = Schema.Make (B)
+  module Bitset = Bitset.Make (B)
 
   type t = Sector.t
   type range = Sector.id * int
@@ -125,12 +126,19 @@ module Make (B : Context.A_DISK) = struct
     in
     size ptr
 
-  let rec push_discarded ~quantity t =
+  let rec push_discarded ~quantity t bitset =
+    let rec free = function
+      | a :: b ->
+        let* () = Bitset.free_range bitset a in
+        free b
+      | [] -> Lwt_result.return ()
+    in
     match B.acquire_discarded () with
     | [] -> Lwt_result.return (t, quantity)
     | lst ->
       let* t = push_back_list t lst in
-      push_discarded ~quantity:(quantity + List.length lst) t
+      let* () = free lst in
+      push_discarded ~quantity:(quantity + List.length lst) t bitset
 
   let push_discarded t = push_discarded ~quantity:0 t
 
@@ -214,32 +222,48 @@ module Make (B : Context.A_DISK) = struct
       go 0 nb acc
     end
 
-  let pop_front t nb =
+  let pop_front t bitset nb =
     let* acc, res = do_pop_front t nb [] in
-    let* t, nb_discarded = push_discarded t in
+    let* t, nb_discarded = push_discarded t bitset in
     match res with
     | Ok_pop -> Lwt_result.return (t, acc, Int64.of_int (nb - nb_discarded))
     | Underflow _ -> Lwt_result.fail `Disk_is_full
 
   type q =
     { free_start : Sector.id
     ; free_queue : t
+    ; bitset : Bitset.t
     ; free_sectors : Int64.t
     }
 
-  let push_back { free_start; free_queue; free_sectors } lst =
+  let push_back { free_start; free_queue; bitset; free_sectors } lst =
+    let rec free = function
+      | a :: b ->
+        let* () = Bitset.free_range bitset a in
+        free b
+      | [] -> Lwt_result.return ()
+    in
+    let* () = free lst in
     let* free_queue = push_back_list free_queue lst in
-    let+ free_queue, nb = push_discarded free_queue in
+    let* free_queue, nb = push_discarded free_queue bitset in
+    let+ _, _, rem = 
+    if Int64.to_int free_sectors > 40 then 
+      pop_front free_queue bitset 2 else Lwt_result.return (free_queue,[],Int64.of_int 0) in
     { free_start
     ; free_queue
-    ; free_sectors = Int64.add free_sectors (Int64.of_int (nb + List.length lst))
+    ; bitset
+    ; free_sectors = Int64.add free_sectors (Int64.of_int (nb + List.length lst - Int64.to_int rem))
     }
 
-  let push_discarded { free_start; free_queue; free_sectors } =
-    let+ free_queue, nb = push_discarded free_queue in
-    { free_start; free_queue; free_sectors = Int64.add free_sectors (Int64.of_int nb) }
+  let push_discarded { free_start; free_queue; bitset; free_sectors } =
+    let+ free_queue, nb = push_discarded free_queue bitset in
+    { free_start
+    ; free_queue
+    ; bitset
+    ; free_sectors = Int64.add free_sectors (Int64.of_int nb)
+    }
 
-  let pop_front { free_start; free_queue; free_sectors } quantity =
+  let pop_front { free_start; free_queue; bitset; free_sectors } quantity =
     let easy_alloc =
       min quantity Int64.(to_int (sub B.nb_sectors (B.Id.to_int64 free_start)))
     in
@@ -249,23 +273,42 @@ module Make (B : Context.A_DISK) = struct
     let+ free_queue, tail, quantity =
       if rest_alloc <= 0
       then Lwt_result.return (free_queue, [], 0L)
-      else pop_front free_queue rest_alloc
+      else pop_front free_queue bitset rest_alloc
     in
     let quantity = Int64.add quantity (Int64.of_int easy_alloc) in
     let q =
       { free_start = B.Id.add free_start easy_alloc
       ; free_queue
+      ; bitset
       ; free_sectors = Int64.sub free_sectors quantity
       }
     in
     q, head @ tail
 
-  let count_new { free_queue = q; _ } = Sector.count_new q
+  let pop_front q quantity =
+    let _ = pop_front in (* just so that pop_front is being used somewhere *)
+    let* lst = Bitset.pop_front q.bitset quantity in 
+    let rec use = function
+      | a :: b ->
+        let* () = Bitset.use_range q.bitset a in
+        use b
+      | [] -> Lwt_result.return ()
+    in
+    let* () = use lst in
+    let+ q = push_discarded q in 
+    q, lst
+
+  let count_new { free_queue = q; bitset = b; _ } =
+    let* bitset_size = Sector.count_new b in
+    let+ queue_size = Sector.count_new q in
+    bitset_size + queue_size
 
-  let finalize { free_start = f; free_queue = q; free_sectors } ids =
-    let+ ts, rest = Sector.finalize q ids in
+  let finalize { free_start = f; free_queue = q; bitset; free_sectors } ids =
+    let* tsqueue, rest = Sector.finalize q ids in
+    let+ tsbitset, rest = Sector.finalize bitset rest in
+    (* List.iter (fun (id, _) -> Format.printf "Bitset at %d@." (Int64.to_int @@ B.Id.to_int64 id)) tsbitset; *)
     assert (rest = []) ;
-    { free_start = f; free_queue = q; free_sectors }, ts
+    { free_start = f; free_queue = q; bitset; free_sectors }, tsqueue @ tsbitset
 
   let allocate ~free_queue sector =
     let* count = Sector.count_new sector in
@@ -313,9 +356,14 @@ module Make (B : Context.A_DISK) = struct
     then alloc_queue [] count free_queue
     else Lwt_result.return (free_queue, [])
 
-  let load (free_start, ptr, free_sectors) =
-    let+ free_queue = if Sector.is_null_ptr ptr then create () else Sector.load ptr in
-    { free_start; free_queue; free_sectors }
+  let load (free_start, queue_ptr, bitset_ptr, free_sectors) =
+    let* free_queue =
+      if Sector.is_null_ptr queue_ptr then create () else Sector.load queue_ptr
+    in
+    let+ bitset =
+      if Sector.is_null_ptr bitset_ptr then Bitset.create () else Sector.load bitset_ptr
+    in
+    { free_start; free_queue; bitset; free_sectors }
 
   let verify_checksum { free_queue = ptr; _ } =
     let rec verify_queue queue =