diff --git a/src/repr/type_binary.ml b/src/repr/type_binary.ml index 2045783f..23d78a03 100644 --- a/src/repr/type_binary.ml +++ b/src/repr/type_binary.ml @@ -96,17 +96,30 @@ module Encode = struct let bytes boxed = if boxed then boxed_bytes else unboxed_bytes - let list l n = - let l = unstage l in - stage (fun x k -> - len n (List.length x) k; - List.iter (fun e -> l e k) x) - - let array l n = - let l = unstage l in - stage (fun x k -> - len n (Array.length x) k; - Array.iter (fun e -> l e k) x) + let list = + let rec encode_elements encode_elt k = function + | [] -> () + | x :: xs -> + encode_elt x k; + (encode_elements [@tailcall]) encode_elt k xs + in + fun l n -> + let l = unstage l in + stage (fun x k -> + len n (List.length x) k; + encode_elements l k x) + + let array = + let encode_elements encode_elt k arr = + for i = 0 to Array.length arr - 1 do + encode_elt (Array.unsafe_get arr i) k + done + in + fun l n -> + let l = unstage l in + stage (fun x k -> + len n (Array.length x) k; + encode_elements l k x) let pair a b = let a = unstage a and b = unstage b in diff --git a/src/repr/type_core.ml b/src/repr/type_core.ml index ba494dc8..1081df07 100644 --- a/src/repr/type_core.ml +++ b/src/repr/type_core.ml @@ -132,8 +132,7 @@ let fold_variant : | _ -> assert false) | CV1 ({ ctag1; cwit1; _ }, v) -> ( match cases.(ctag1) with - | Dispatch.Arrow { f; arg_wit } -> ( - match Witness.cast cwit1 arg_wit v with - | Some v -> unstage f v - | None -> assert false) + | Dispatch.Arrow { f; arg_wit } -> + let v = Witness.cast_exn cwit1 arg_wit v in + unstage f v | _ -> assert false)) diff --git a/src/repr/witness.ml b/src/repr/witness.ml index c57a11a2..8eade5e2 100644 --- a/src/repr/witness.ml +++ b/src/repr/witness.ml @@ -35,5 +35,16 @@ let make : type a. unit -> a t = let eq : type a b. a t -> b t -> (a, b) eq option = fun (module A) (module B) -> match A.Eq with B.Eq -> Some Refl | _ -> None +let eq_exn : type a b. a t -> b t -> (a, b) eq = + fun (module A) (module B) -> + match A.Eq with + | B.Eq -> Refl + | _ -> failwith "Repr.internal_error: unexpected runtime type inequality" + let cast : type a b. a t -> b t -> a -> b option = fun awit bwit a -> match eq awit bwit with Some Refl -> Some a | None -> None + +let cast_exn : type a b. a t -> b t -> a -> b = + fun awit bwit a -> + let Refl = eq_exn awit bwit in + a diff --git a/src/repr/witness.mli b/src/repr/witness.mli index d76456f4..7ab35f32 100644 --- a/src/repr/witness.mli +++ b/src/repr/witness.mli @@ -19,4 +19,6 @@ type 'a t val make : unit -> 'a t val eq : 'a t -> 'b t -> ('a, 'b) eq option +val eq_exn : 'a t -> 'b t -> ('a, 'b) eq val cast : 'a t -> 'b t -> 'a -> 'b option +val cast_exn : 'a t -> 'b t -> 'a -> 'b