cohttp.headers: use faster comparison

Signed-off-by: Marcello Seri <[email protected]>

CHANGES.md

@@ -8,7 +8,7 @@
   stack overflow happens in the XHR completion handler (mefyl #762).
 - lwt_jsoo: Add test suite (mefyl #764).
 
-- Cohttp.Header: new implementation (@lyrm #747)
+- Cohttp.Header: new implementation (lyrm #747)
 
   + New implementation of Header modules using an associative list instead of a map, with one major semantic change (function ```get```, see below), and some new functions (```clean_dup```, ```get_multi_concat```)
   + More Alcotest tests as well as fuzzing tests for this particular module.
@@ -38,6 +38,7 @@
 
   + ```clean_dup```  enables the user to clean headers that follows the {{:https://tools.ietf.org/html/rfc7230#section-3.2.2} RFC7230§3.2.2} (no duplicate, except ```set-cookie```)
   + ```get_multi_concat``` has been added to get a result similar to the previous ```get``` function.
+- Cohttp.Header: optimize internal of cohttp.headers (mseri #778)
 
 ## v4.0.0 (2021-03-24)
 

cohttp/src/header.ml

@@ -21,13 +21,26 @@ module LString : sig
 
   val of_string : string -> t
   val to_string : t -> string
-  val compare : t -> t -> int
+  val equal : t -> t -> bool
 end = struct
   type t = string
 
   let of_string x = String.lowercase_ascii x
   let to_string x = x
-  let compare a b = String.compare a b
+
+  let equal x y =
+    let len = String.length x in
+    len = String.length y
+    &&
+    let equal_so_far = ref true in
+    let i = ref 0 in
+    while !equal_so_far && !i < len do
+      let c1 = String.unsafe_get x !i in
+      let c2 = String.unsafe_get y !i in
+      equal_so_far := c1 = c2;
+      incr i
+    done;
+    !equal_so_far
 end
 
 type t = (LString.t * string) list
@@ -41,7 +54,7 @@ let mem h k =
   let k = LString.of_string k in
   let rec loop = function
     | [] -> false
-    | (k', _) :: h' -> if LString.compare k k' = 0 then true else loop h'
+    | (k', _) :: h' -> if LString.equal k k' then true else loop h'
   in
   loop h
 
@@ -62,25 +75,25 @@ let get h k =
   let rec loop h =
     match h with
     | [] -> None
-    | (k', v) :: h' -> if LString.compare k k' = 0 then Some v else loop h'
+    | (k', v) :: h' -> if LString.equal k k' then Some v else loop h'
   in
   loop h
 
 let get_multi (h : t) (k : string) =
+  let k = LString.of_string k in
   let rec loop h acc =
     match h with
     | [] -> acc
     | (k', v) :: h' ->
-        if LString.compare (LString.of_string k) k' = 0 then loop h' (v :: acc)
-        else loop h' acc
+        if LString.equal k k' then loop h' (v :: acc) else loop h' acc
   in
   loop h []
 
 let remove h k =
   let k = LString.of_string k in
   let rec loop seen = function
     | [] -> if seen then [] else raise Not_found
-    | (k', _) :: h when LString.compare k k' = 0 -> loop true h
+    | (k', _) :: h when LString.equal k k' -> loop true h
     | x :: h -> x :: loop seen h
   in
   try loop false h with Not_found -> h
@@ -89,7 +102,7 @@ let remove_last h k =
   let k = LString.of_string k in
   let rec loop seen = function
     | [] -> raise Not_found
-    | (k', _) :: h when LString.compare k k' = 0 -> h
+    | (k', _) :: h when LString.equal k k' -> h
     | x :: h -> x :: loop seen h
   in
   try loop false h with Not_found -> h
@@ -98,7 +111,7 @@ let replace_ last h k v =
   let k' = LString.of_string k in
   let rec loop seen = function
     | [] -> if seen then [] else raise Not_found
-    | (k'', _) :: h when LString.compare k' k'' = 0 ->
+    | (k'', _) :: h when LString.equal k' k'' ->
         if last then (k'', v) :: h
         else if not seen then (k', v) :: loop true h
         else loop seen h
@@ -202,23 +215,25 @@ let is_header_with_list_value =
   headers_with_list_values |> Array.iter (fun h -> Hashtbl.add tbl h ());
   fun h -> Hashtbl.mem tbl h
 
-let is_set_cookie k = LString.(compare k (of_string "set-cookie"))
+let is_set_cookie =
+  let k' = LString.of_string "set-cookie" in
+  fun k -> LString.equal k k'
 
 (* set-cookie is an exception according to
    {{:https://tools.ietf.org/html/rfc7230#section-3.2.2}
-   RFC7230§3.2.2} and can appear multiple times in a response message.
+    RFC7230§3.2.2} and can appear multiple times in a response message.
 *)
 let clean_dup (h : t) : t =
   let add h k v =
-    if is_set_cookie k = 0 then (k, v) :: h
+    if is_set_cookie k then (k, v) :: h
     else
       let to_add = ref false in
       let rec loop = function
         | [] ->
             to_add := true;
             []
         | (k', v') :: hs ->
-            if LString.compare k k' = 0 then
+            if LString.equal k k' then
               if is_header_with_list_value k then (k, v' ^ "," ^ v) :: hs
               else (
                 to_add := true;