]> matita.cs.unibo.it Git - helm.git/blobdiff - helm/software/components/ng_kernel/nCicReduction.ml
- hExtlib: added debugging information for split_nth
[helm.git] / helm / software / components / ng_kernel / nCicReduction.ml
index 59443bb1a3e048f2b3ee3abb74f57099a2c4a36a..aa7f84ad660428a9109e47fcf02fc97a81365f24 100644 (file)
@@ -15,12 +15,14 @@ module C = NCic
 module Ref = NReference
 module E = NCicEnvironment
 
+exception AssertFailure of string Lazy.t;;
+
 module type Strategy = sig
   type stack_term
   type env_term
   type config = int * env_term list * C.term * stack_term list
   val to_env :
-   reduce: (config -> config) -> unwind: (config -> C.term) ->
+   reduce: (config -> config * bool) -> unwind: (config -> C.term) ->
     config -> env_term
   val from_stack : stack_term -> config
   val from_stack_list_for_unwind :
@@ -29,13 +31,13 @@ module type Strategy = sig
   val from_env_for_unwind :
    unwind: (config -> C.term) -> env_term -> C.term
   val stack_to_env :
-   reduce: (config -> config) -> unwind: (config -> C.term) ->
+   reduce: (config -> config * bool) -> unwind: (config -> C.term) ->
     stack_term -> env_term
   val compute_to_env :
-   reduce: (config -> config) -> unwind: (config -> C.term) ->
+   reduce: (config -> config * bool) -> unwind: (config -> C.term) ->
     int -> env_term list -> C.term -> env_term
   val compute_to_stack :
-   reduce: (config -> config) -> unwind: (config -> C.term) ->
+   reduce: (config -> config * bool) -> unwind: (config -> C.term) ->
     config -> stack_term
  end
 ;;
@@ -44,7 +46,7 @@ module CallByValueByNameForUnwind' = struct
   type config = int * env_term list * C.term * stack_term list
   and stack_term = config lazy_t * C.term lazy_t (* cbv, cbn *)
   and env_term = config lazy_t * C.term lazy_t (* cbv, cbn *)
-  let to_env ~reduce ~unwind c = lazy (reduce c),lazy (unwind c)
+  let to_env ~reduce ~unwind c = lazy (fst (reduce c)),lazy (unwind c)
   let from_stack (c,_) = Lazy.force c
   let from_stack_list_for_unwind ~unwind:_ l = 
    List.map (function (_,c) -> Lazy.force c) l
@@ -52,9 +54,9 @@ module CallByValueByNameForUnwind' = struct
   let from_env_for_unwind ~unwind:_ (_,c) = Lazy.force c
   let stack_to_env ~reduce:_ ~unwind:_ config = config
   let compute_to_env ~reduce ~unwind k e t =
-   lazy (reduce (k,e,t,[])), lazy (unwind (k,e,t,[]))
+   lazy (fst (reduce (k,e,t,[]))), lazy (unwind (k,e,t,[]))
   let compute_to_stack ~reduce ~unwind config = 
-   lazy (reduce config), lazy (unwind config)
+   lazy (fst (reduce config)), lazy (unwind config)
  end
 ;;
 
@@ -82,7 +84,7 @@ module Reduction(RS : Strategy) = struct
     | _,_ -> assert false
   ;;
 
-  let rec reduce ~delta ?(subst = []) context : config -> config = 
+  let rec reduce ~delta ?(subst = []) context : config -> config * bool 
    let rec aux = function
      | k, e, C.Rel n, s when n <= k ->
         let k',e',t',s' = RS.from_env (list_nth e (n-1)) in
@@ -91,16 +93,16 @@ module Reduction(RS : Strategy) = struct
         let x= try Some (List.nth context (n - 1 - k)) with Failure _ -> None in
          (match x with
          | Some(_,C.Def(x,_)) -> aux (0,[],NCicSubstitution.lift (n - k) x,s)
-         | _ -> config)
+         | _ -> config, true)
      | (k, e, C.Meta (n,l), s) as config ->
         (try 
            let _,_, term,_ = NCicUtils.lookup_subst n subst in
            aux (k, e, NCicSubstitution.subst_meta l term,s)
-         with  NCicUtils.Subst_not_found _ -> config)
+         with  NCicUtils.Subst_not_found _ -> config, true)
      | (_, _, C.Implicit _, _) -> assert false
      | (_, _, C.Sort _, _)
      | (_, _, C.Prod _, _)
-     | (_, _, C.Lambda _, []) as config -> config
+     | (_, _, C.Lambda _, []) as config -> config, true
      | (k, e, C.Lambda (_,_,t), p::s) ->
          aux (k+1, (RS.stack_to_env ~reduce:aux ~unwind p)::e, t,s)
      | (k, e, C.LetIn (_,_,m,t), s) ->
@@ -114,50 +116,63 @@ module Reduction(RS : Strategy) = struct
          aux (k, e, he, tl' @ s)
      | (_, _, C.Const
             (Ref.Ref (_,Ref.Def height) as refer), s) as config ->
-         if delta >= height then config else 
+         if delta >= height then 
+           config, false
+         else 
            let _,_,body,_,_,_ = NCicEnvironment.get_checked_def refer in
            aux (0, [], body, s) 
      | (_, _, C.Const (Ref.Ref (_,
-            (Ref.Decl|Ref.Ind _|Ref.Con _|Ref.CoFix _))), _) as config -> config
-     | (_, _, C.Const (Ref.Ref 
-           (_,Ref.Fix (fixno,recindex,height)) as refer),s) as config ->
-        if delta >= height then config else
+         (Ref.Decl|Ref.Ind _|Ref.Con _|Ref.CoFix _))), _) as config -> 
+           config, true
+     | (_, _, (C.Const (Ref.Ref 
+           (_,Ref.Fix (fixno,recindex,height)) as refer) as head),s) as config ->
+(*         if delta >= height then config else *)
         (match
           try Some (RS.from_stack (List.nth s recindex))
           with Failure _ -> None
         with 
-        | None -> config
+        | None -> config, true
         | Some recparam ->
            let fixes,_,_ = NCicEnvironment.get_checked_fixes_or_cofixes refer in
            match reduce ~delta:0 ~subst context recparam with
-           | (_,_,C.Const (Ref.Ref (_,Ref.Con _)), _) as c ->
+           | (_,_,C.Const (Ref.Ref (_,Ref.Con _)), _) as c, _ 
+              when delta >= height ->
+               let new_s =
+                 replace recindex s (RS.compute_to_stack ~reduce:aux ~unwind c)
+               in
+               (0, [], head, new_s), false
+           | (_,_,C.Const (Ref.Ref (_,Ref.Con _)), _) as c, _ ->
                let new_s =
                  replace recindex s (RS.compute_to_stack ~reduce:aux ~unwind c)
                in
                let _,_,_,_,body = List.nth fixes fixno in
                aux (0, [], body, new_s)
-           | _ -> config)
+           | _ -> config, true)
      | (k, e, C.Match (_,_,term,pl),s) as config ->
         let decofix = function
           | (_,_,C.Const(Ref.Ref(_,Ref.CoFix c)as refer),s)->
-             let cofixes,_,_ = NCicEnvironment.get_checked_fixes_or_cofixes refer in
+             let cofixes,_,_ = 
+               NCicEnvironment.get_checked_fixes_or_cofixes refer in
              let _,_,_,_,body = List.nth cofixes c in
-             reduce ~delta:0 ~subst context (0,[],body,s)
+             let c,_ = reduce ~delta:0 ~subst context (0,[],body,s) in 
+             c
           | config -> config
         in
-        (match decofix (reduce ~delta:0 ~subst context (k,e,term,[])) with
+        let match_head = k,e,term,[] in
+        let reduced,_ = reduce ~delta:0 ~subst context match_head in
+        (match decofix reduced with
         | (_, _, C.Const (Ref.Ref (_,Ref.Con (_,j,_))),[]) ->
             aux (k, e, List.nth pl (j-1), s)
         | (_, _, C.Const (Ref.Ref (_,Ref.Con (_,j,lno))), s')->
-          let _,params = HExtlib.split_nth lno s' in
+          let _,params = HExtlib.split_nth "NR 1" lno s' in
           aux (k, e, List.nth pl (j-1), params@s)
-        | _ -> config)
+        | _ -> config, true)
    in
     aux
   ;;
 
-  let whd ?(delta=0) ?(subst=[]) context t = 
-   unwind (reduce ~delta ~subst context (0, [], t, []))
+  let whd ?(delta=0) ~subst context t = 
+   unwind (fst (reduce ~delta ~subst context (0, [], t, [])))
   ;;
 
  end
@@ -171,21 +186,14 @@ let whd = R.whd
 
 let (===) x y = Pervasives.compare x y = 0 ;;
 
-exception Dance;;
+let get_relevance = ref (fun ~metasenv:_ ~subst:_ _ _ -> assert false);;
+
+let set_get_relevance f = get_relevance := f;;
 
-let prof = HExtlib.profiling_enabled := true;HExtlib.profile "cache failures";;
-let prof2 = HExtlib.profiling_enabled := true;HExtlib.profile "dancing sorts";;
 (* t1, t2 must be well-typed *)
-let are_convertible ?(subst=[]) get_relevance =
- let get_relevance_p ~subst context t args =
-   (match prof with {HExtlib.profile = p} -> p)
-   (fun (a,b,c,d) -> get_relevance ~subst:a b c d)
-   (subst,context,t,args)
- in
- let dance () = (match prof2 with {HExtlib.profile = p} -> p) (fun () -> ()) ()
- in
+let are_convertible ~metasenv ~subst =
  let rec aux test_eq_only context t1 t2 =
-   let rec alpha_eq test_eq_only t1 t2 =
+   let alpha_eq test_eq_only t1 t2 =
      if t1 === t2 then
        true
      else
@@ -219,7 +227,12 @@ let are_convertible ?(subst=[]) get_relevance =
               (NCicSubstitution.lift s1 t1) 
               (NCicSubstitution.lift s2 t2))  
             l1 l2
-          with Invalid_argument _ -> assert false) -> true
+          with Invalid_argument "List.for_all2" -> 
+            prerr_endline ("Meta " ^ string_of_int n1 ^ 
+              " occurrs with local contexts of different lenght\n"^
+              NCicPp.ppterm ~metasenv ~subst ~context t1 ^ " === " ^
+              NCicPp.ppterm ~metasenv ~subst ~context t2);
+            assert false) -> true
 
        | C.Meta (n1,l1), _ ->
           (try 
@@ -234,46 +247,44 @@ let are_convertible ?(subst=[]) get_relevance =
               aux test_eq_only context t1 term
            with NCicUtils.Subst_not_found _ -> false)
        
-       | (C.Appl ((C.Const r1) as _hd1::tl1), C.Appl (C.Const r2::tl2)) 
+       | (C.Appl ((C.Const r1) as hd1::tl1), C.Appl (C.Const r2::tl2)) 
            when (Ref.eq r1 r2 && 
              List.length (E.get_relevance r1) >= List.length tl1) ->
          let relevance = E.get_relevance r1 in
          let relevance = match r1 with
              | Ref.Ref (_,Ref.Con (_,_,lno)) ->
-                 let _,relevance = HExtlib.split_nth lno relevance in
+                 let _,relevance = HExtlib.split_nth "NR 2" lno relevance in
                    HExtlib.mk_list false lno @ relevance
              | _ -> relevance
          in
-        let fail = ref ~-1 in
-         let res = (try
-             HExtlib.list_forall_default3
-              (fun t1 t2 b -> fail := !fail+1; not b || aux test_eq_only context t1 t2)
+         (try
+             HExtlib.list_forall_default3_var
+              (fun t1 t2 b -> not b || aux true context t1 t2 )
               tl1 tl2 true relevance
-            with Invalid_argument _ -> false)
-         in res
-        (* if res then true
-         else
-          let relevance = get_relevance_p ~subst context _hd1 tl1 in
-          let _,relevance = HExtlib.split_nth !fail relevance in
-          let b,relevance = (match relevance with
-            | [] -> assert false
-            | b::tl -> b,tl) in
-          let _,tl1 = HExtlib.split_nth (!fail+1) tl1 in
-          let _,tl2 = HExtlib.split_nth (!fail+1) tl2 in
-          if (not b) then
-             (dance ();
-             try
-               HExtlib.list_forall_default3
-                (fun t1 t2 b -> not b || aux test_eq_only context t1 t2)
-                tl1 tl2 true relevance
-             with Invalid_argument _ -> false)
-          else false *)
-       | (C.Appl (hd1::tl1), C.Appl (hd2::tl2)) ->
+            with Invalid_argument _ -> false
+              | HExtlib.FailureAt fail ->
+                let relevance = 
+                   !get_relevance ~metasenv ~subst context hd1 tl1 in
+                let _,relevance = HExtlib.split_nth "NR 3" fail relevance in
+                let b,relevance = (match relevance with
+                  | [] -> assert false
+                  | b::tl -> b,tl) in
+                if (not b) then
+                  let _,tl1 = HExtlib.split_nth "NR 4" (fail+1) tl1 in
+                  let _,tl2 = HExtlib.split_nth "NR 5" (fail+1) tl2 in
+                    try
+                        HExtlib.list_forall_default3
+                        (fun t1 t2 b -> not b || aux true context t1 t2)
+                        tl1 tl2 true relevance
+                     with Invalid_argument _ -> false
+                else false)
+
+       | (C.Appl (hd1::tl1),  C.Appl (hd2::tl2)) ->
            aux test_eq_only context hd1 hd2 &&
-          let relevance = get_relevance ~subst context hd1 tl1 in
-           (try
+          let relevance = !get_relevance ~metasenv ~subst context hd1 tl1 in
+            (try
              HExtlib.list_forall_default3
-              (fun t1 t2 b -> not b || aux test_eq_only context t1 t2)
+              (fun t1 t2 b -> not b || aux true context t1 t2)
               tl1 tl2 true relevance
             with Invalid_argument _ -> false)
 
@@ -311,15 +322,28 @@ let are_convertible ?(subst=[]) get_relevance =
       | C.Appl(C.Const(Ref.Ref(_,Ref.Fix (_,_,h)))::_) -> h
       | _ -> 0
      in
-     let small_delta_step (_,_,t1,_ as m1) (_,_,t2,_ as m2) = 
-       let h1 = height_of t1 in 
-       let h2 = height_of t2 in
-       let delta = if h1 = h2 then max 0 (h1 -1) else min h1 h2 in
-       R.reduce ~delta ~subst context m1,
-       R.reduce ~delta ~subst context m2,
-       delta
+     let put_in_whd m1 m2 =
+       R.reduce ~delta:max_int ~subst context m1,
+       R.reduce ~delta:max_int ~subst context m2
      in
-     let rec convert_machines ((k1,e1,t1,s1 as m1),(k2,e2,t2,s2 as m2),delta) =
+     let small_delta_step 
+       ((_,_,t1,_ as m1), norm1 as x1) ((_,_,t2,_ as m2), norm2 as x2) 
+     = 
+       assert(not (norm1 && norm2));
+       if norm1 then
+         x1, R.reduce ~delta:(height_of t2 -1) ~subst context m2
+       else if norm2 then
+         R.reduce ~delta:(height_of t1 -1) ~subst context m1, x2
+       else
+        let h1 = height_of t1 in 
+        let h2 = height_of t2 in
+        let delta = if h1 = h2 then max 0 (h1 -1) else min h1 h2 in
+        R.reduce ~delta ~subst context m1,
+        R.reduce ~delta ~subst context m2
+     in
+     let rec convert_machines test_eq_only
+       ((k1,e1,t1,s1),norm1 as m1),((k2,e2,t2,s2), norm2 as m2) 
+     =
        (alpha_eq test_eq_only
          (R.unwind (k1,e1,t1,[])) (R.unwind (k2,e2,t2,[])) &&
         let relevance =
@@ -332,35 +356,64 @@ let are_convertible ?(subst=[]) get_relevance =
              not b ||
              let t1 = RS.from_stack t1 in
              let t2 = RS.from_stack t2 in
-             convert_machines (small_delta_step t1 t2)) s1 s2 true relevance
+             convert_machines true (put_in_whd t1 t2)) s1 s2 true relevance
         with Invalid_argument _ -> false) || 
-       (delta > 0 &&
-          let delta = delta - 1 in 
-          let red = R.reduce ~delta ~subst context in
-          convert_machines (red m1,red m2,delta))
+       (not (norm1 && norm2) && convert_machines test_eq_only (small_delta_step m1 m2))
      in
-     convert_machines (small_delta_step (0,[],t1,[]) (0,[],t2,[]))
+     convert_machines test_eq_only (put_in_whd (0,[],t1,[]) (0,[],t2,[]))
  in
   aux false 
 ;;
 
-let rec head_beta_reduce ?(delta=max_int) ?(upto=(-1)) t l =
+let rec head_beta_reduce ~delta ~upto ~subst t l =
  match upto, t, l with
   | 0, C.Appl l1, _ -> C.Appl (l1 @ l)
   | 0, t, [] -> t
   | 0, t, _ -> C.Appl (t::l)
-  | _, C.Appl (hd::tl), _ -> head_beta_reduce ~delta ~upto hd (tl @ l)
+  | _, C.Meta (n,ctx), _ ->
+     (try
+       let _,_, term,_ = NCicUtils.lookup_subst n subst in
+       head_beta_reduce ~delta ~upto ~subst 
+         (NCicSubstitution.subst_meta ctx term) l
+     with NCicUtils.Subst_not_found _ -> if l = [] then t else C.Appl (t::l))
+  | _, C.Appl (hd::tl), _ -> head_beta_reduce ~delta ~upto ~subst hd (tl @ l)
   | _, C.Lambda(_,_,bo), arg::tl ->
      let bo = NCicSubstitution.subst arg bo in
-     head_beta_reduce ~delta ~upto:(upto - 1) bo tl
+     head_beta_reduce ~delta ~upto:(upto - 1) ~subst bo tl
   | _, C.Const (Ref.Ref (_, Ref.Def height) as re), _ 
     when delta <= height ->
       let _, _, bo, _, _, _ = NCicEnvironment.get_checked_def re in
-      head_beta_reduce ~upto ~delta bo l
+      head_beta_reduce ~upto ~delta ~subst bo l
   | _, t, [] -> t
   | _, t, _ -> C.Appl (t::l)
 ;;
 
-let head_beta_reduce ?delta ?upto t = head_beta_reduce ?delta ?upto t [];;
+let head_beta_reduce ?(delta=max_int) ?(upto= -1) ?(subst=[]) t = 
+  head_beta_reduce ~delta ~upto ~subst t []
+;;
+
+type stack_item = RS.stack_term
+type environment_item = RS.env_term
+
+type machine = int * environment_item list * NCic.term * stack_item list
+
+let reduce_machine = R.reduce
+let from_stack = RS.from_stack
+let unwind = R.unwind
+
+let _ = 
+  NCicUtils.set_head_beta_reduce (fun ~upto t -> head_beta_reduce ~upto t);
+  NCicPp.set_head_beta_reduce (fun ~upto t -> head_beta_reduce ~upto t);
+;;
+
+(* if n < 0, then splits all prods from an arity, returning a sort *)
+let rec split_prods ~subst context n te =
+  match (n, R.whd ~subst context te) with
+   | (0, _) -> context,te
+   | (n, C.Sort _) when n <= 0 -> context,te
+   | (n, C.Prod (name,so,ta)) ->
+       split_prods ~subst ((name,(C.Decl so))::context) (n - 1) ta
+   | (_, _) -> raise (AssertFailure (lazy "split_prods"))
+;;
 
 (* vim:set foldmethod=marker: *)