Source file eqaf.ml

let[@inline always] char_chr ch =
  (* Char.chr contains a branch on [ch] and a plt indirection, this
   * implementation ensures well-formedness by construction and avoids that: *)
  Char.unsafe_chr (ch land 0xff)

let[@inline] get x i = String.unsafe_get x i |> Char.code

(* XXX(dinosaure): we use [unsafe_get] to avoid jump to exception:

        sarq    $1, %rbx
        movzbq  (%rax,%rbx), %rax
        leaq    1(%rax,%rax), %rax
        ret
*)

external unsafe_get_int16 : string -> int -> int = "%caml_string_get16u"
let[@inline] get16 x i = unsafe_get_int16 x i

(* XXX(dinosaure): same as [unsafe_get] but for [int16]:

        sarq    $1, %rbx
        movzwq  (%rax,%rbx), %rax
        leaq    1(%rax,%rax), %rax
        ret
*)

let equal ~ln a b =
  let l1 = ln asr 1 in

  (*
        sarq    $1, %rcx
        orq     $1, %rcx
  *)

  let r = ref 0 in

  (*
        movq    $1, %rdx
  *)

  for i = 0 to pred l1 do r := !r lor (get16 a (i * 2) lxor get16 b (i * 2)) done ;

  (*
        movq    $1, %rsi
        addq    $-2, %rcx
        cmpq    %rcx, %rsi
        jg      .L104
.L105:
        leaq    -1(%rsi,%rsi), %r8

        sarq    $1, %r8
        movzwq  (%rdi,%r8), %r9
        leaq    1(%r9,%r9), %r9
        movzwq  (%rbx,%r8), %r8
        leaq    1(%r8,%r8), %r8

     // [unsafe_get_int16 a i] and [unsafe_get_int6 b i]

        xorq    %r9, %r8
        orq     $1, %r8
        orq     %r8, %rdx
        movq    %rsi, %r8
        addq    $2, %rsi
        cmpq    %rcx, %r8
        jne     .L105
.L104:
  *)

  for _ = 1 to ln land 1 do r := !r lor (get a (ln - 1) lxor get b (ln - 1)) done ;

  (*
        movq    $3, %rsi
        movq    %rax, %rcx
        andq    $3, %rcx
        cmpq    %rcx, %rsi
        jg      .L102
.L103:
        movq    %rax, %r8
        addq    $-2, %r8

        sarq    $1, %r8
        movzbq  (%rdi,%r8), %r9
        leaq    1(%r9,%r9), %r9
        movzbq  (%rbx,%r8), %r8
        leaq    1(%r8,%r8), %r8

     // [unsafe_get a i] and [unsafe_get b i]

        xorq    %r9, %r8
        orq     $1, %r8
        orq     %r8, %rdx
        movq    %rsi, %r8
        addq    $2, %rsi
        cmpq    %rcx, %r8
        jne     .L103
.L102:
  *)

  !r = 0

(*
        cmpq    $1, %rdx
        sete    %al
        movzbq  %al, %rax
        leaq    1(%rax,%rax), %rax
        ret
*)

let equal a b =
  let al = String.length a in
  let bl = String.length b in
  if al <> bl
  then false
  else equal ~ln:al a b

let[@inline always] compare (a:int) b = a - b
let[@inline always] sixteen_if_minus_one_or_less n = (n asr Sys.int_size) land 16
let[@inline always] eight_if_one_or_more n = ((-n) asr Sys.int_size) land 8

let compare_le ~ln a b =
  let r = ref 0 in
  let i = ref (pred ln) in

  while !i >= 0 do
    let xa = get a !i and xb = get b !i in
    let c = compare xa xb in
    r := !r lor ((sixteen_if_minus_one_or_less c + eight_if_one_or_more c) lsr !r) ;
    decr i ;
  done ;

  (!r land 8) - (!r land 16)

let compare_le_with_len ~len:ln a b =
  let al = String.length a in
  let bl = String.length b in
  if ln = 0 then 0
  else if (al lxor ln) lor (bl lxor ln) <> 0
  then invalid_arg "compare_le_with_len"
  else compare_le ~ln a b

let compare_le a b =
  let al = String.length a in
  let bl = String.length b in
  if al < bl
  then 1
  else if al > bl
  then (-1)
  else compare_le ~ln:al (* = bl *) a b

let compare_be ~ln a b =
  let r = ref 0 in
  let i = ref 0 in

  while !i < ln do
    let xa = get a !i and xb = get b !i in
    let c = compare xa xb in
    r := !r lor ((sixteen_if_minus_one_or_less c + eight_if_one_or_more c) lsr !r) ;
    incr i ;
  done ;

  (!r land 8) - (!r land 16)

let compare_be_with_len ~len:ln a b =
  let al = String.length a in
  let bl = String.length b in
  if ln = 0 then 0
  else if (al lxor ln) lor (bl lxor ln) <> 0
  then invalid_arg "compare_be_with_len"
  else compare_be ~ln a b

let compare_be a b =
  let al = String.length a in
  let bl = String.length b in
  if al < bl then 1
  else if al > bl then (-1)
  else compare_be ~ln:al (* = bl *) a b

let[@inline always] minus_one_or_less n =
  n lsr (Sys.int_size - 1)

let[@inline always] one_if_not_zero n =
  minus_one_or_less ((- n) lor n)

let[@inline always] zero_if_not_zero n =
  (one_if_not_zero n) - 1

let[@inline always] select_int choose_b a b =
  let mask = ((- choose_b) lor choose_b) asr Sys.int_size in
  (a land (lnot mask)) lor (b land mask)

external int_of_bool : bool -> int = "%identity"
external unsafe_bool_of_int : int -> bool = "%identity"

let[@inline] bool_of_int n =
  unsafe_bool_of_int (one_if_not_zero n)

let[@inline always] find_uint8 ~off ~len ~f str =
  let i = ref (len - 1) in
  let a = ref (lnot 0) in
  while !i >= off do
    let byte = get str !i in
    let pred = int_of_bool (f byte) in
    (* XXX(dinosaure): a composition of [f] with [bool_of_int] such as
       [let f = bool_of_int <.> f in] implies an allocation (of a closure).
       To be GC-free, we must store result of [f] into a register, and apply
       [bool_of_int] then (introspection was done on OCaml 4.08.1). *)
    a := select_int (((!i - off) land min_int) lor pred) !a !i ;
    decr i ;
  done ; !a

let find_uint8 ?(off= 0) ~f str =
  (* XXX(dinosaure): with this overload, OCaml is able to produce 2 [find_uint8].
     One with [off= 0] and one other where [off] is an argument. I think it's about
     cross-module optimization where a call to [find_uint8 ~f v] will directly call
     the first one and a call to [find_uint8 ~off:x ~f v] will call the second one. *)
  let len = String.length str in
  find_uint8 ~off ~len ~f str

let exists_uint8 ?off ~f str =
  let v = find_uint8 ?off ~f str in
  let r = select_int (v + 1) 0 1 in
  unsafe_bool_of_int r

let divmod ~(x:int32) ~(m:int32) : int32 * int32 =
  (* Division and remainder being constant-time with respect to [x]
   * ( NOT [m] !). The OCaml variant would be:
   * [(x / m , x mod m)] where [x] is a secret and [m] is not secret.
   * Adapted from the NTRU Prime team's algorithm from
   * supercop/crypto_kem/sntrup761/ref/uint32.c
   * cite the round-2 ntru prime submission to nistpqc (march 2019)
   * Note that in practice this works for at least some much larger [x] and [m],
   * but it's unclear to me how to evaluate *which*, so leaving the original
   * restrictions in.
  *)
  let ( - ) , ( + ), ( * ) = Int32.(sub, add, mul) in
  let ( >> ) = Int32.shift_right_logical in
  if (m <= 0l) then raise (Invalid_argument "m <= 0") ;
  if (m >= 16348l) then raise (Invalid_argument "m >= 16348 not supported") ;

  let of_uint32 uint =
    (* apparently Int64.of_int32 sign-extends ... great... avoid that: *)
    let b = Bytes.make 8 '\x00' in
    Unsafe.set_int32_le b 0 uint ;
    Unsafe.get_int64_le b 0
  in

  let x_0 = x in

  let x_2, q_1 =
    let int32_div_unsigned n d =
      (* can be replaced by Int32.unsigned_div
       * from OCaml >= 4.10 *)
      let sub,min_int = Int32.(sub,min_int)in
      let int32_unsigned_compare n m =
        Int32.compare (sub n min_int) (sub m min_int)
      in
      if d < 0_l then
        if int32_unsigned_compare n d < 0 then 0_l else 1_l
      else
        let q =
          let open Int32 in
          shift_left (Int32.div (Int32.shift_right_logical n 1) d) 1 in
        let r = sub n (Int32.mul q d) in
        if int32_unsigned_compare r d >= 0 then Int32.succ q else q
    in
    let v = int32_div_unsigned Int32.min_int m |> of_uint32 in
    (*let v = 0x80_00_00_00 / m in*) (* floored div *)
    let x_1, q_0 =
      let qpart_0 =
        let open Int64 in
        shift_right_logical (mul (of_uint32 x_0) v) 31
        |> to_int32
      in
      x_0 - (qpart_0 * m), qpart_0
    in
    let qpart_1 =
      let open Int64 in
      shift_right_logical (mul (of_uint32 x_1) v) 31
      |> to_int32 in
    x_1 - (qpart_1 * m),
    (q_0 + qpart_1 + 1l) in
  let x_3 = x_2 - m  in
  let mask = 0l - (x_3 >> 31) in
  q_1 + mask, x_3 + (Int32.logand mask m)

let ascii_of_int32 ~digits (n:int32) : string =
  (* Recursively calls [divmod n 10]; the remainder is turned into ASCII
     and the quotient is used for the next division.*)
  if digits < 0 then raise (Invalid_argument "digits < 0");
  let out = Bytes.make digits '0' in
  let rec loop x = function
    | -1 -> Bytes.unsafe_to_string out
    | idx ->
      let next, this = divmod ~x ~m:10l in
      Bytes.set out idx @@ char_chr (0x30 lor (Int32.to_int this)) ;
      loop next (pred idx)
  in loop n (pred digits)

let[@inline always] to_hex_nibble f : char =
  let a = 86 + f in
  let c = 1 + ((a - 71 * ((a land 0x10) lsr 4)) lor 0x20) in
  char_chr c

let hex_of_string rawbytes =
  String.init (2 * String.length rawbytes)
    (fun idx ->
       let byt = String.get rawbytes (idx lsr 1) |> Char.code in
       (* select which 4 bits to use, this can probably be done faster:*)
       let nib = 0xf land (byt lsr (((lnot idx) land 1) lsl 2)) in
       to_hex_nibble nib)

let hex_of_bytes rawbytes = hex_of_string (Bytes.unsafe_to_string rawbytes)

let[@inline always] select_a_if_in_range ~low ~high ~n a b =
  (* select [a] if [low <= n <= high] and [b] if [n] is out of range.*)
  (* NB: ONLY WORKS FOR [0 <= low <= high <= max_int]*)
  (* The idea being that:
     1.a) if low <=   n : (n - low)  is positive +
     1.b) if low  >   n : (n - low)  is negative -
     2.a) if   n <= high: (high - n) is positive +
     2.b) if   n  > high: (high - n) is negative -
     We OR the numbers together; we only really care about the sign bit
     which is set when negative.
     Thus both numbers are positive iff (low <= n && n <= high).
     We then select the sign bit with (land min_int) and use that to choose:
  *)
  let out_of_range = (* choose b if out of range *)
    ((n - low) lor (high - n)
     land min_int)
  in
  select_int out_of_range a b

let lowercase_ascii src =
  (* ct version of String.lowercase_ascii *)
  String.map
    ( fun ch -> let n = Char.code ch in
      (* 0x41 is 'A'; 0x5a is 'Z'; 0x20 controls case for ASCII letters *)
      select_a_if_in_range ~low:0x41 ~high:0x5a ~n (n lor 0x20) (n)
      |> char_chr
    ) src

let uppercase_ascii src =
  (* ct version of String.uppercase_ascii *)
  String.map
    ( fun ch -> let n = Char.code ch in
      (* 0x61 is 'a'; 0x7a is 'z'; 0x20 controls case for ASCII letters *)
      select_a_if_in_range ~low:0x61 ~high:0x7a ~n (n lxor 0x20) (n)
      |> char_chr
    ) src

let bytes_of_hex rawhex =
  (* hex length must be multiple of 2: *)
  let error_bitmap = ref ((String.length rawhex land 1) lsl 4) in
  let decoded =
    Bytes.init (String.length rawhex lsr 1)
      (fun idx ->
         let idx = idx lsl 1 in
         let nib idx =
           String.get rawhex idx
           |> Char.code
           |> fun n -> (* uppercase -> lowercase: *)
           select_a_if_in_range ~low:0x41 ~high:0x5a
             ~n
             (n lor 0x20) (* set case bit *)
             n (* leave as-is *)
           |> fun n -> (* now either invalid; lowercase; numeric*)
           (select_a_if_in_range ~low:0x30 ~high:0x39
              ~n
              (n - 0x30) (* numeric: subtract '0' to get [0..9] *)
              (select_a_if_in_range ~low:0x61 ~high:0x66
                 ~n
                 (* a-f: subtract 'a' and add 10 to get [10..15]: *)
                 (n - 0x61 + 10)
                 (0xff) (* invalid, ensure we set upper bits of error_bitmap *)
              )
           )
         in
         let nibf0 = nib idx
         and nib0f = nib (succ idx) in
         error_bitmap := !error_bitmap lor nibf0 lor nib0f ;
         char_chr ((nibf0 lsl 4) lor nib0f)
      )
  in
  (* if any non-nibble bits were set in !error_bitmap, decoding failed: *)
  decoded, !error_bitmap land (lnot 0xf)

let string_of_hex rawhex =
  let byt, error = bytes_of_hex rawhex in
  Bytes.unsafe_to_string byt, error