Merge pull request #38 from dinosaure/avoid-unsigned-to-int

hannesm · web-flow · commit cdab0405f356 · 2025-03-06T13:35:48.000+01:00
Avoid an 'a option allocation when we cast a int32 into a int on 64-bit architecture
diff --git a/bench/checksum.ml b/bench/checksum.ml
@@ -0,0 +1,32 @@
+open Bechamel
+open Toolkit
+
+let payload =
+  let ln = 3_000 in
+  let ba = Bigarray.(Array1.create char c_layout ln) in
+  Bigarray.Array1.fill ba '\xff'; ba
+
+let checksum = Staged.stage @@ fun () ->
+  ignore (Utcp.Checksum.digest payload)
+
+let test =
+  Test.make ~name:"checksum" checksum
+
+let benchmark () =
+  let ols = Analyze.ols ~bootstrap:0 ~r_square:true ~predictors:Measure.[| run |] in
+  let instances = Instance.[ monotonic_clock ] in
+  let cfg = Benchmark.cfg ~limit:2000 ~stabilize:true ~quota:(Time.second 1.) ~kde:(Some 1000) () in
+  let raw = Benchmark.all cfg instances test in
+  let results = List.map (fun inst -> Analyze.all ols inst raw) instances in
+  let results = Analyze.merge ols instances results in
+  (results, raw)
+
+let nothing _ = Ok ()
+
+let () =
+  let results = benchmark () in
+  let results =
+    let open Bechamel_js in
+    emit ~dst:(Channel stdout) nothing ~x_label:Measure.run
+      ~y_label:(Measure.label Instance.monotonic_clock) results in
+  match results with Ok () -> () | Error (`Msg err) -> failwith err
diff --git a/bench/dune b/bench/dune
@@ -0,0 +1,11 @@
+(executable
+ (name checksum)
+ (libraries bechamel bechamel-js utcp))
+
+(rule
+ (targets checksum.json)
+ (action (with-stdout-to %{targets} (run ./checksum.exe))))
+
+(rule
+ (targets checksum.html)
+ (action (system "%{bin:bechamel-html} < %{dep:checksum.json} > %{targets}")))
diff --git a/src/checksum.ml b/src/checksum.ml
@@ -23,6 +23,18 @@ external unsafe_get_uint8 : bigstring -> int -> int = "%caml_ba_unsafe_ref_1"
 external unsafe_get_uint16 : bigstring -> int -> int = "%caml_bigstring_get16u"
 external swap16 : int -> int = "%bswap16"
 external swap32 : int32 -> int32 = "%bswap_int32"
+external int32_to_int : int32 -> int = "%int32_to_int"
+
+let mask = 0xffff lsl 16 lor 0xffff
+let int32_to_int n = int32_to_int n land mask
+
+(* NOTE(dinosaure): Users may wonder why we use access with a bound-check (such
+   as [bufX.{...}]). The reason is simple: OCaml, with regard to bigarrays, can
+   unbox [int16]/[int32] if such access is desired. Furthermore, using a
+   function such as [unsafe_get_int{16,32}] would not allow OCaml to correctly
+   infer this access and to "prepare the ground" for unboxing. It should be
+   noted that bound-check is not the most expensive (and quite predictable in
+   reality), but unbox is. *)
 
 let unsafe_digest_16_le ?(off = 0) ~len:top buf =
   let buf16 = to_int16 ~off ~len:top buf in
@@ -40,13 +52,14 @@ let unsafe_digest_16_le ?(off = 0) ~len:top buf =
   if !sum > 0xffff then incr sum;
   swap16 (lnot !sum land 0xffff)
 
+(* NOTE(dinosaure): only work on 64-bit architecture. *)
 let unsafe_digest_32_le ?(off = 0) ~len:top buf =
   let buf32 = to_int32 ~off ~len:top buf in
   let len = ref top in
   let sum = ref 0 in
   let i = ref 0 in
   while !len >= 4 do
-    let[@warning "-8"] (Some v) = Int32.unsigned_to_int buf32.{!i} in
+    let v = int32_to_int buf32.{!i} in
     sum := !sum + v;
     incr i;
     len := !len - 4
@@ -60,13 +73,14 @@ let unsafe_digest_32_le ?(off = 0) ~len:top buf =
   done;
   swap16 (lnot !sum land 0xffff)
 
+(* NOTE(dinosaure): only work on 64-bit architecture. *)
 let unsafe_digest_32_be ?(off = 0) ~len:top buf =
   let buf32 = to_int32 ~off ~len:top buf in
   let len = ref top in
   let sum = ref 0 in
   let i = ref 0 in
   while !len >= 4 do
-    let[@warning "-8"] (Some v) = Int32.unsigned_to_int (swap32 buf32.{!i}) in
+    let v = int32_to_int (swap32 buf32.{!i}) in
     sum := !sum + v;
     incr i;
     len := !len - 4
diff --git a/utcp.opam b/utcp.opam
@@ -36,6 +36,8 @@ depends: [
   "pcap-format" {>= "0.6.0" & dev}
   "alcotest" {>= "1.5.0" & with-test}
   "crowbar" {>= "0.2.1" & with-test}
+  "bechamel" {with-test}
+  "bechamel-js" {with-test}
 ]
 build: [
   ["dune" "subst"] {dev}

Original file line number	Diff line number	Diff line change
`@@ -36,6 +36,8 @@ depends: [`
`36`	`36`	`"pcap-format" {>= "0.6.0" & dev}`
`37`	`37`	`"alcotest" {>= "1.5.0" & with-test}`
`38`	`38`	`"crowbar" {>= "0.2.1" & with-test}`
	`39`	`+ "bechamel" {with-test}`
	`40`	`+ "bechamel-js" {with-test}`
`39`	`41`	`]`
`40`	`42`	`build: [`
`41`	`43`	`["dune" "subst"] {dev}`