Optimized the hot inner loop.

diff --git a/lib/.depend b/lib/.depend
index fa24106..8fc3cf7 100644 (file)
--- a/lib/.depend
+++ b/lib/.depend
@@ -43,5 +43,9 @@ diskimage_utils.cmo: int63.cmi diskimage_utils.cmi
 diskimage_utils.cmx: int63.cmx diskimage_utils.cmi 
 int63.cmo: int63.cmi 
 int63.cmx: int63.cmi 
+int63_on_32.cmo: int63_on_32.cmi 
+int63_on_32.cmx: int63_on_32.cmi 
+int63_on_64.cmo: int63_on_64.cmi 
+int63_on_64.cmx: int63_on_64.cmi 
 test_int63.cmo: int63.cmi 
 test_int63.cmx: int63.cmx 

diff --git a/lib/diskimage.ml b/lib/diskimage.ml
index 807094a..f2b5823 100644 (file)
--- a/lib/diskimage.ml
+++ b/lib/diskimage.ml
@@ -665,8 +665,29 @@ let get_owners_lookup machine ownership (disk : block_device) =
   let tree = List.assoc (disk :> device) ownership in
 
   fun offset ->
+    (* Warning: This 'hot' code was carefully optimized based on
+     * feedback from 'gprof'.  Avoid fiddling with it.
+     *)
     let rec query = function
       | Leaf (_, segments) -> segments
+
+      (* Try to avoid expensive '@' operator if node segments is empty: *)
+      | Node ((Leaf ((_, leftend), _) | Node (_, ((_, leftend), _), _) as left),
+             (_, []),
+             right) ->
+         let subsegments =
+           if offset < leftend then query left else query right in
+         subsegments
+
+      (* ... or a singleton: *)
+      | Node ((Leaf ((_, leftend), _) | Node (_, ((_, leftend), _), _) as left),
+             (_, [segment]),
+             right) ->
+         let subsegments =
+           if offset < leftend then query left else query right in
+         segment :: subsegments
+
+      (* Normal recursive case: *)
       | Node ((Leaf ((_, leftend), _) | Node (_, ((_, leftend), _), _) as left),
              (_, segments),
              right) ->