Fix issue with sizeof-rewriting and monomorphisation

Sizeof-rewriting could introduce extra arguments to functions that
instantiate_simple_equations could fill in with overly complicated
types, causing unification to fail when building lem.

2 files changed, 15 insertions, 4 deletions

diff --git a/lib/mono_rewrites.sail b/lib/mono_rewrites.sail
index 9e837e10..0825f9d0 100644
--- a/lib/mono_rewrites.sail
+++ b/lib/mono_rewrites.sail
@@ -63,7 +63,7 @@ function slice_slice_concat (xs, i, l, ys, i', l') = {
   extzv(xs) << l' | extzv(ys)
 }
 
-val slice_zeros_concat : forall 'n 'p 'q 'r, 'r = 'p + 'q & 'n >= 0 & 'p >= 0 & 'q >= 0 & 'r >= 0.
+val slice_zeros_concat : forall 'n 'p 'q 'r, 'r == 'p + 'q & 'n >= 0 & 'p >= 0 & 'q >= 0 & 'r >= 0.
   (bits('n), int, atom('p), atom('q)) -> bits('r) effect pure
 
 function slice_zeros_concat (xs, i, l, l') = {
@@ -82,13 +82,15 @@ function subrange_subrange_eq (xs, i, j, ys, i', j') = {
   xs == ys
 }
 
-val subrange_subrange_concat : forall 'n 'o 'p 'm 'q 'r 's, 's = 'o - ('p - 1) + 'q - ('r - 1) & 'n >= 0 & 'm >= 0.
+val subrange_subrange_concat : forall 'n 'o 'p 'm 'q 'r 's, 's == 'o - ('p - 1) + 'q - ('r - 1) & 'n >= 0 & 'm >= 0.
   (bits('n), atom('o), atom('p), bits('m), atom('q), atom('r)) -> bits('s) effect pure
 
 function subrange_subrange_concat (xs, i, j, ys, i', j') = {
   let xs = (xs & slice_mask(j,i-j+1)) >> j in
   let ys = (ys & slice_mask(j',i'-j'+1)) >> j' in
-  extzv(xs) << (i' - j' + 1) | extzv(ys)
+  // We need to avoid sizeof-rewriting
+  // extzv(xs) << (i' - j' + 1) | extzv(ys)
+  extz_vec(i - (j - 1) + i' - (j' - 1), xs) << (i' - j' + 1) | extz_vec(i - (j - 1) + i' - (j' - 1), ys)
 }
 
 val place_subrange : forall 'n 'm, 'n >= 0 & 'm >= 0.
diff --git a/src/type_check.ml b/src/type_check.ml
index 0f083823..3cfa4bb6 100644
--- a/src/type_check.ml
+++ b/src/type_check.ml
@@ -2897,7 +2897,7 @@ and bind_assignment env (LEXP_aux (lexp_aux, _) as lexp) (E_aux (_, (l, ())) as
           let checked_exp = crule check_exp env exp (lexp_typ_of inferred_lexp) in
           annot_assign inferred_lexp checked_exp, env
         with Type_error (l, err') -> typ_raise l (Err_because (err', err))
-          
+
 and bind_lexp env (LEXP_aux (lexp_aux, (l, ())) as lexp) typ =
   typ_print (lazy ("Binding mutable " ^ string_of_lexp lexp ^  " to " ^ string_of_typ typ));
   let annot_lexp_effect lexp typ eff = LEXP_aux (lexp, (l, Some ((env, typ, eff),None))) in
@@ -3260,6 +3260,7 @@ and instantiation_of_without_type (E_aux (exp_aux, (l, _)) as exp) =
   | _ -> invalid_arg ("instantiation_of expected application,  got " ^ string_of_exp exp)
 
 and infer_funapp' l env f (typq, f_typ) xs expected_ret_typ =
+  typ_print (lazy (Util.("Function " |> cyan |> clear) ^ string_of_id f));
   let annot_exp exp typ eff = E_aux (exp, (l, Some ((env, typ, eff), expected_ret_typ))) in
   let is_bound env kid = KBindings.mem kid (Env.get_typ_vars env) in
 
@@ -3282,6 +3283,14 @@ and infer_funapp' l env f (typq, f_typ) xs expected_ret_typ =
     | _ -> typ_error l (string_of_typ f_typ ^ " is not a function type")
   in
 
+  let unifiers = instantiate_simple_equations !quants in
+  typ_debug (lazy "Instantiating from equations");
+  typ_debug (lazy (string_of_list ", " (fun (kid, arg) -> string_of_kid kid ^ " => " ^ string_of_typ_arg arg) (KBindings.bindings unifiers)));
+  all_unifiers := unifiers;
+  let typ_args = List.map (subst_unifiers unifiers) typ_args in
+  List.iter (fun unifier -> quants := instantiate_quants !quants unifier) (KBindings.bindings unifiers);
+  List.iter (fun (v, arg) -> typ_ret := typ_subst v arg !typ_ret) (KBindings.bindings unifiers);
+
   typ_debug (lazy ("Quantifiers " ^ Util.string_of_list ", " string_of_quant_item !quants));
 
   if not (List.length typ_args = List.length xs) then