chore: Prepare odiff for the image io redistribution

Also did good old profiling and fixed some of the inefficienceis in the
main loop

bin/Main.ml

@@ -30,8 +30,10 @@ let main img1Path img2Path diffPath threshold outputDiffMask failOnLayoutChange
     Gc.set
       {
         (Gc.get ()) with
-        (* 128 MB *)
-        major_heap_increment = 128 * 1024 * 1024;
+        (* 16MB is a reasonable value for minor heap size *)
+        minor_heap_size = 2 * 1024 * 1024;
+        (* Double the minor heap *)
+        major_heap_increment = 2 * 1024 * 1024;
         (* Reasonable high value to reduce major GC frequency *)
         space_overhead = 500;
         (* Disable compaction *)

io/bmp/Bmp.ml

@@ -9,11 +9,15 @@ module IO : Odiff.ImageIO.ImageIO = struct
     let width, height, data = ReadBmp.load filename in
     { width; height; image = data }
 
-  let readDirectPixel ~(x : int) ~(y : int) (img : t Odiff.ImageIO.img) =
+  let readRawPixel ~(x : int) ~(y : int) (img : t Odiff.ImageIO.img) =
     let image : data = img.image in
     Array1.unsafe_get image ((y * img.width) + x)
   [@@inline]
 
+  let readRawPixelAtOffset offset (img : t Odiff.ImageIO.img) =
+    Array1.unsafe_get img.image offset
+  [@@inline]
+
   let setImgColor ~x ~y color (img : t Odiff.ImageIO.img) =
     let image : data = img.image in
     Array1.unsafe_set image ((y * img.width) + x) color

io/jpg/Jpg.ml

@@ -9,8 +9,13 @@ module IO = struct
     let width, height, data = ReadJpg.read_jpeg_image filename in
     { width; height; image = { data } }
 
-  let readDirectPixel ~x ~y (img : t Odiff.ImageIO.img) =
-    Array1.unsafe_get img.image.data ((y * img.width) + x)
+  let readRawPixel ~x ~y (img : t Odiff.ImageIO.img) =
+    (Array1.unsafe_get img.image.data ((y * img.width) + x) [@inline.always])
+  [@@inline]
+
+  let readRawPixelAtOffset offset (img : t Odiff.ImageIO.img) =
+    Array1.unsafe_get img.image.data offset
+  [@@inline]
 
   let setImgColor ~x ~y color (img : t Odiff.ImageIO.img) =
     Array1.unsafe_set img.image.data ((y * img.width) + x) color

io/png/Png.ml

@@ -6,9 +6,14 @@ type data = (int32, int32_elt, c_layout) Array1.t
 module IO : Odiff.ImageIO.ImageIO = struct
   type t = data
 
-  let readDirectPixel ~(x : int) ~(y : int) (img : t Odiff.ImageIO.img) =
+  let readRawPixelAtOffset offset (img : t Odiff.ImageIO.img) =
+    Array1.unsafe_get img.image offset
+  [@@inline always]
+
+  let readRawPixel ~(x : int) ~(y : int) (img : t Odiff.ImageIO.img) =
     let image : data = img.image in
     Array1.unsafe_get image ((y * img.width) + x)
+  [@@inline always]
 
   let setImgColor ~x ~y color (img : t Odiff.ImageIO.img) =
     let image : data = img.image in

io/tiff/Tiff.ml

@@ -1,17 +1,21 @@
 open Bigarray
+open Odiff.ImageIO
 
 type data = (int32, int32_elt, c_layout) Array1.t
 
-module IO : Odiff.ImageIO.ImageIO = struct
+module IO : ImageIO = struct
   type buffer
   type t = { data : data }
 
   let loadImage filename : t Odiff.ImageIO.img =
     let width, height, data = ReadTiff.load filename in
     { width; height; image = { data } }
 
-  let readDirectPixel ~(x : int) ~(y : int) (img : t Odiff.ImageIO.img) =
-    Array1.unsafe_get img.image.data ((y * img.width) + x)
+  let readRawPixel ~x ~y img =
+    (Array1.unsafe_get img.image.data ((y * img.width) + x) [@inline.always])
+
+  let readRawPixelAtOffset offset img = Array1.unsafe_get img.image.data offset
+  [@@inline.always]
 
   let setImgColor ~x ~y color (img : t Odiff.ImageIO.img) =
     Array1.unsafe_set img.image.data ((y * img.width) + x) color

src/Antialiasing.ml

@@ -39,13 +39,11 @@ module MakeAntialiasing (IO1 : ImageIO.ImageIO) (IO2 : ImageIO.ImageIO) = struct
         | false -> 0)
     in
 
-    let baseColor = baseImg |> IO1.readDirectPixel ~x ~y in
+    let baseColor = baseImg |> IO1.readRawPixel ~x ~y in
     for adj_y = y0 to y1 do
       for adj_x = x0 to x1 do
         if !zeroes < 3 && (x <> adj_x || y <> adj_y) then
-          let adjacentColor =
-            baseImg |> IO1.readDirectPixel ~x:adj_x ~y:adj_y
-          in
+          let adjacentColor = baseImg |> IO1.readRawPixel ~x:adj_x ~y:adj_y in
           if baseColor = adjacentColor then incr zeroes
           else
             let delta =
@@ -75,15 +73,11 @@ module MakeAntialiasing (IO1 : ImageIO.ImageIO) (IO2 : ImageIO.ImageIO) = struct
       let minX, minY = !minSiblingDeltaCoord in
       let maxX, maxY = !maxSiblingDeltaCoord in
       (hasManySiblingsWithSameColor ~x:minX ~y:minY ~width:baseImg.width
-         ~height:baseImg.height
-         ~readColor:(IO1.readDirectPixel baseImg)
+         ~height:baseImg.height ~readColor:(IO1.readRawPixel baseImg)
       || hasManySiblingsWithSameColor ~x:maxX ~y:maxY ~width:baseImg.width
-           ~height:baseImg.height
-           ~readColor:(IO1.readDirectPixel baseImg))
+           ~height:baseImg.height ~readColor:(IO1.readRawPixel baseImg))
       && (hasManySiblingsWithSameColor ~x:minX ~y:minY ~width:compImg.width
-            ~height:compImg.height
-            ~readColor:(IO2.readDirectPixel compImg)
+            ~height:compImg.height ~readColor:(IO2.readRawPixel compImg)
          || hasManySiblingsWithSameColor ~x:maxX ~y:maxY ~width:compImg.width
-              ~height:compImg.height
-              ~readColor:(IO2.readDirectPixel compImg))
+              ~height:compImg.height ~readColor:(IO2.readRawPixel compImg))
 end

src/ColorDelta.ml

@@ -1,43 +1,53 @@
+open Int32
+
+type pixel = { r : float; g : float; b : float; a : float }
+
+let white_pixel : pixel = { r = 255.; g = 255.; b = 255.; a = 0. }
 let blend_channel_white color alpha = 255. +. ((color -. 255.) *. alpha)
-let white_pixel = (255., 255., 255., 0.)
 
-let blendSemiTransparentColor = function
-  | r, g, b, 0. -> white_pixel
-  | r, g, b, 255. -> (r, g, b, 1.)
-  | r, g, b, alpha when alpha < 255. ->
-      let normalizedAlpha = alpha /. 255. in
+let blendSemiTransparentPixel = function
+  | { r; g; b; a } when a = 0. -> white_pixel
+  | { r; g; b; a } when a = 255. -> { r; g; b; a = 1. }
+  | { r; g; b; a } when a < 255. ->
+      let normalizedAlpha = a /. 255. in
       let r, g, b, a =
         ( blend_channel_white r normalizedAlpha,
           blend_channel_white g normalizedAlpha,
           blend_channel_white b normalizedAlpha,
           normalizedAlpha )
       in
-      (r, g, b, a)
+
+      { r; g; b; a }
   | _ ->
       failwith
         "Found pixel with alpha value greater than uint8 max value. Aborting."
 
-let convertPixelToFloat pixel =
-  let pixel = pixel |> Int32.to_int in
-  let a = (pixel lsr 24) land 255 in
-  let b = (pixel lsr 16) land 255 in
-  let g = (pixel lsr 8) land 255 in
-  let r = pixel land 255 in
-
-  (Float.of_int r, Float.of_int g, Float.of_int b, Float.of_int a)
-
-let rgb2y (r, g, b, a) =
+let decodeRawPixel pixel =
+  let a = logand (shift_right_logical pixel 24) 255l in
+  let b = logand (shift_right_logical pixel 16) 255l in
+  let g = logand (shift_right_logical pixel 8) 255l in
+  let r = logand pixel 255l in
+
+  {
+    r = Int32.to_float r;
+    g = Int32.to_float g;
+    b = Int32.to_float b;
+    a = Int32.to_float a;
+  }
+[@@inline]
+
+let rgb2y { r; g; b; a } =
   (r *. 0.29889531) +. (g *. 0.58662247) +. (b *. 0.11448223)
 
-let rgb2i (r, g, b, a) =
+let rgb2i { r; g; b; a } =
   (r *. 0.59597799) -. (g *. 0.27417610) -. (b *. 0.32180189)
 
-let rgb2q (r, g, b, a) =
+let rgb2q { r; g; b; a } =
   (r *. 0.21147017) -. (g *. 0.52261711) +. (b *. 0.31114694)
 
-let calculatePixelColorDelta _pixelA _pixelB =
-  let pixelA = _pixelA |> convertPixelToFloat |> blendSemiTransparentColor in
-  let pixelB = _pixelB |> convertPixelToFloat |> blendSemiTransparentColor in
+let calculatePixelColorDelta pixelA pixelB =
+  let pixelA = pixelA |> decodeRawPixel |> blendSemiTransparentPixel in
+  let pixelB = pixelB |> decodeRawPixel |> blendSemiTransparentPixel in
 
   let y = rgb2y pixelA -. rgb2y pixelB in
   let i = rgb2i pixelA -. rgb2i pixelB in
@@ -47,6 +57,6 @@ let calculatePixelColorDelta _pixelA _pixelB =
   delta
 
 let calculatePixelBrightnessDelta pixelA pixelB =
-  let pixelA = pixelA |> convertPixelToFloat |> blendSemiTransparentColor in
-  let pixelB = pixelB |> convertPixelToFloat |> blendSemiTransparentColor in
+  let pixelA = pixelA |> decodeRawPixel |> blendSemiTransparentPixel in
+  let pixelB = pixelB |> decodeRawPixel |> blendSemiTransparentPixel in
   rgb2y pixelA -. rgb2y pixelB

src/Diff.ml

@@ -1,3 +1,5 @@
+open Int32
+
 (* Decimal representation of the RGBA in32 pixel red pixel *)
 let redPixel = Int32.of_int 4278190335
 
@@ -6,22 +8,28 @@ let maxYIQPossibleDelta = 35215.
 
 type 'a diffVariant = Layout | Pixel of ('a * int * float * int Stack.t)
 
-let computeIgnoreRegionOffsets width =
-  List.map (fun ((x1, y1), (x2, y2)) ->
-      let p1 = (y1 * width) + x1 in
-      let p2 = (y2 * width) + x2 in
-      (p1, p2))
+let unrollIgnoreRegions width list =
+  list
+  |> Option.map
+       (List.map (fun ((x1, y1), (x2, y2)) ->
+            let p1 = (y1 * width) + x1 in
+            let p2 = (y2 * width) + x2 in
+            (p1, p2)))
 
-let isInIgnoreRegion offset =
-  List.exists (fun ((p1 : int), (p2 : int)) -> offset >= p1 && offset <= p2)
+let isInIgnoreRegion offset list =
+  list
+  |> Option.map
+       (List.exists (fun ((p1 : int), (p2 : int)) ->
+            offset >= p1 && offset <= p2))
+  |> Option.value ~default:false
 
 module MakeDiff (IO1 : ImageIO.ImageIO) (IO2 : ImageIO.ImageIO) = struct
   module BaseAA = Antialiasing.MakeAntialiasing (IO1) (IO2)
   module CompAA = Antialiasing.MakeAntialiasing (IO2) (IO1)
 
   let compare (base : IO1.t ImageIO.img) (comp : IO2.t ImageIO.img)
       ?(antialiasing = false) ?(outputDiffMask = false) ?(diffLines = false)
-      ?diffPixel ?(threshold = 0.1) ?(ignoreRegions = []) () =
+      ?diffPixel ?(threshold = 0.1) ~ignoreRegions () =
     let maxDelta = maxYIQPossibleDelta *. (threshold ** 2.) in
     let diffPixel = match diffPixel with Some x -> x | None -> redPixel in
     let diffOutput =
@@ -42,30 +50,31 @@ module MakeDiff (IO1 : ImageIO.ImageIO) (IO2 : ImageIO.ImageIO) = struct
       then diffLinesStack |> Stack.push y
     in
 
-    let ignoreRegions =
-      ignoreRegions |> computeIgnoreRegionOffsets base.width
-    in
+    let ignoreRegions = unrollIgnoreRegions base.width ignoreRegions in
+    let hasIgnoreRegions = ignoreRegions |> Option.is_some in
 
     let size = (base.height * base.width) - 1 in
     let x = ref 0 in
     let y = ref 0 in
 
     for offset = 0 to size do
+      let baseColor = IO1.readRawPixelAtOffset offset base in
+
       (if !x >= comp.width || !y >= comp.height then (
-         let alpha =
-           (Int32.to_int (IO1.readDirectPixel ~x:!x ~y:!y base) lsr 24) land 255
-         in
-         if alpha <> 0 then countDifference !x !y)
+         let alpha = logand (shift_right_logical baseColor 24) 255l in
+         if alpha <> Int32.zero then countDifference !x !y)
        else
-         let baseColor = IO1.readDirectPixel ~x:!x ~y:!y base in
-         let compColor = IO2.readDirectPixel ~x:!x ~y:!y comp in
+         let compColor = IO2.readRawPixelAtOffset offset comp in
          if baseColor <> compColor then
-           let delta =
-             ColorDelta.calculatePixelColorDelta baseColor compColor
+           let isIgnored =
+             hasIgnoreRegions && isInIgnoreRegion offset ignoreRegions
            in
-           if delta > maxDelta then
-             let isIgnored = isInIgnoreRegion offset ignoreRegions in
-             if not isIgnored then
+
+           if not isIgnored then
+             let delta =
+               ColorDelta.calculatePixelColorDelta baseColor compColor
+             in
+             if delta > maxDelta then
                let isAntialiased =
                  if not antialiasing then false
                  else
@@ -88,7 +97,7 @@ module MakeDiff (IO1 : ImageIO.ImageIO) (IO2 : ImageIO.ImageIO) = struct
 
   let diff (base : IO1.t ImageIO.img) (comp : IO2.t ImageIO.img) ~outputDiffMask
       ?(threshold = 0.1) ~diffPixel ?(failOnLayoutChange = true)
-      ?(antialiasing = false) ?(diffLines = false) ?(ignoreRegions = []) () =
+      ?(antialiasing = false) ?(diffLines = false) ?ignoreRegions () =
     if
       failOnLayoutChange = true
       && (base.width <> comp.width || base.height <> comp.height)

src/ImageIO.ml

@@ -7,7 +7,8 @@ module type ImageIO = sig
 
   val loadImage : string -> t img
   val makeSameAsLayout : t img -> t img
-  val readDirectPixel : x:int -> y:int -> t img -> Int32.t
+  val readRawPixelAtOffset : int -> t img -> Int32.t [@@inline.always]
+  val readRawPixel : x:int -> y:int -> t img -> Int32.t [@@inline.always]
   val setImgColor : x:int -> y:int -> Int32.t -> t img -> unit
   val saveImage : t img -> string -> unit
   val freeImage : t img -> unit

src/dune

@@ -7,8 +7,8 @@
 (env
  (dev
   (flags (:standard -w +42))
-  (ocamlopt_flags (:standard -S)))
+  (ocamlopt_flags (:standard -unsafe)))
  (release
-  (ocamlopt_flags (:standard -O3 -rounds 5 -unbox-closures -inline 200 -inline-max-depth 7 -unbox-closures-factor 50))))
+  (ocamlopt_flags (:standard -unsafe -O3 -rounds 5 -unboxed-types -unbox-closures -inline 200 -inline-max-depth 7 -unbox-closures-factor 50))))