Merge PR coq#8708: Stupid but critical unfolding heuristic.

ggonthier · Oct 22, 2018 · 2d714eb · 2d714eb
2 parents e605b73 + 1af1761
commit 2d714eb
Show file tree

Hide file tree

Showing 2 changed files with 24 additions and 6 deletions.
diff --git a/checker/reduction.ml b/checker/reduction.ml
@@ -280,17 +280,26 @@ let get_strategy { var_opacity; cst_opacity } = function
       with Not_found -> default_level)
   | RelKey _ -> Expand
 
+let dep_order l2r k1 k2 = match k1, k2 with
+| RelKey _, RelKey _ -> l2r
+| RelKey _, (VarKey _ | ConstKey _) -> true
+| VarKey _, RelKey _ -> false
+| VarKey _, VarKey _ -> l2r
+| VarKey _, ConstKey _ -> true
+| ConstKey _, (RelKey _ | VarKey _) -> false
+| ConstKey _, ConstKey _ -> l2r
+
 let oracle_order infos l2r k1 k2 =
   let o = Closure.oracle_of_infos infos in
   match get_strategy o k1, get_strategy o k2 with
-  | Expand, Expand -> l2r
+  | Expand, Expand -> dep_order l2r k1 k2
   | Expand, (Opaque | Level _) -> true
   | (Opaque | Level _), Expand -> false
-  | Opaque, Opaque -> l2r
+  | Opaque, Opaque -> dep_order l2r k1 k2
   | Level _, Opaque -> true
   | Opaque, Level _ -> false
   | Level n1, Level n2 ->
-     if Int.equal n1 n2 then l2r
+     if Int.equal n1 n2 then dep_order l2r k1 k2
      else n1 < n2
 
 let eq_table_key univ =

diff --git a/kernel/conv_oracle.ml b/kernel/conv_oracle.ml
@@ -83,18 +83,27 @@ let fold_strategy f { var_opacity; cst_opacity; _ } accu =
 
 let get_transp_state { var_trstate; cst_trstate; _ } = (var_trstate, cst_trstate)
 
+let dep_order l2r k1 k2 = match k1, k2 with
+| RelKey _, RelKey _ -> l2r
+| RelKey _, (VarKey _ | ConstKey _) -> true
+| VarKey _, RelKey _ -> false
+| VarKey _, VarKey _ -> l2r
+| VarKey _, ConstKey _ -> true
+| ConstKey _, (RelKey _ | VarKey _) -> false
+| ConstKey _, ConstKey _ -> l2r
+
 (* Unfold the first constant only if it is "more transparent" than the
    second one. In case of tie, use the recommended default. *)
 let oracle_order f o l2r k1 k2 =
   match get_strategy o f k1, get_strategy o f k2 with
-  | Expand, Expand -> l2r
+  | Expand, Expand -> dep_order l2r k1 k2
   | Expand, (Opaque | Level _) -> true
   | (Opaque | Level _), Expand -> false
-  | Opaque, Opaque -> l2r
+  | Opaque, Opaque -> dep_order l2r k1 k2
   | Level _, Opaque -> true
   | Opaque, Level _ -> false
   | Level n1, Level n2 ->
-     if Int.equal n1 n2 then l2r
+     if Int.equal n1 n2 then dep_order l2r k1 k2
      else n1 < n2
 
 let get_strategy o = get_strategy o (fun x -> x)