]> matita.cs.unibo.it Git - helm.git/blob - helm/software/components/ng_refiner/nCicMetaSubst.ml
New style debugging/profiling for NCicMetaSubst.
[helm.git] / helm / software / components / ng_refiner / nCicMetaSubst.ml
1 (*
2     ||M||  This file is part of HELM, an Hypertextual, Electronic        
3     ||A||  Library of Mathematics, developed at the Computer Science     
4     ||T||  Department, University of Bologna, Italy.                     
5     ||I||                                                                
6     ||T||  HELM is free software; you can redistribute it and/or         
7     ||A||  modify it under the terms of the GNU General Public License   
8     \   /  version 2 or (at your option) any later version.      
9      \ /   This software is distributed as is, NO WARRANTY.     
10       V_______________________________________________________________ *)
11
12 (* $Id$ *)
13
14 let debug = ref false;;
15 let indent = ref "";;
16 let times = ref [];;
17 let pp s =
18  if !debug then
19   prerr_endline (Printf.sprintf "%-20s" !indent ^ " " ^ Lazy.force s)
20 ;;
21 let inside c =
22  if !debug then
23   begin
24    let time1 = Unix.gettimeofday () in
25    indent := !indent ^ String.make 1 c;
26    times := time1 :: !times;
27    prerr_endline ("{{{" ^ !indent ^ " ")
28   end
29 ;;
30 let outside exc_opt =
31  if !debug then
32   begin
33    let time2 = Unix.gettimeofday () in
34    let time1 =
35     match !times with time1::tl -> times := tl; time1 | [] -> assert false in
36    prerr_endline ("}}} " ^ string_of_float (time2 -. time1));
37    (match exc_opt with
38    | Some e ->  prerr_endline ("exception raised: " ^ Printexc.to_string e)
39    | None -> ());
40    try
41     indent := String.sub !indent 0 (String.length !indent -1)
42    with
43     Invalid_argument _ -> indent := "??"; ()
44   end
45 ;;
46
47 exception MetaSubstFailure of string Lazy.t
48 exception Uncertain of string Lazy.t
49
50 let newmeta,maxmeta = 
51   let maxmeta = ref 0 in
52   (fun () -> incr maxmeta; !maxmeta),
53   (fun () -> !maxmeta)
54 ;;
55
56 exception NotInTheList;;
57
58 let position to_skip n (shift, lc) =
59   match lc with
60   | NCic.Irl _ when to_skip > 0 -> assert false  (* unclear to me *)
61   | NCic.Irl len when n <= shift || n > shift + len -> raise NotInTheList
62   | NCic.Irl _ -> n - shift
63   | NCic.Ctx tl ->
64       let rec aux to_skip k = function 
65          | [] -> raise NotInTheList
66          | _ :: tl when to_skip > 0 -> aux (to_skip - 1) (k+1) tl
67          | (NCic.Rel m)::_ when m + shift = n -> k
68          | _::tl -> aux to_skip (k+1) tl 
69       in
70        aux to_skip 1 tl
71 ;;
72
73 let pack_lc orig = 
74   let rec are_contiguous k = function
75     | [] -> true
76     | (NCic.Rel j) :: tl when j = k+1 -> are_contiguous j tl
77     | _ -> false
78   in
79   match orig with
80   | _, NCic.Ctx [] -> 0, NCic.Irl 0
81   | shift, NCic.Ctx (NCic.Rel k::tl as l) when are_contiguous k tl ->
82       shift+k-1, NCic.Irl (List.length l)
83   | _ -> orig
84 ;;
85
86
87
88 let mk_perforated_irl shift len restrictions =
89   let rec aux n =
90     if n = 0 then [] else
91      if List.mem (n+shift) restrictions then aux (n-1)
92      else (NCic.Rel n) :: aux (n-1)
93   in
94     pack_lc (shift, NCic.Ctx (List.rev (aux len)))
95 ;;
96
97 exception Occur;;
98
99 let rec force_does_not_occur metasenv subst restrictions t =
100  let rec aux k ms = function
101     | NCic.Rel r when List.mem (r - k) restrictions -> raise Occur
102     | NCic.Rel r as orig ->
103         let amount = 
104           List.length (List.filter (fun x -> x < r - k) restrictions) 
105         in
106         if amount > 0 then ms, NCic.Rel (r - amount) else ms, orig
107     | NCic.Meta (n, (shift,lc as l)) as orig ->
108        let meta_chain =
109         try
110          Some (NCicUtils.lookup_subst n subst)
111         with
112          NCicUtils.Subst_not_found _ -> None
113        in
114         (match meta_chain with
115             Some (_,_,bo,_) ->
116              aux k ms (NCicSubstitution.subst_meta l bo)
117           | None ->
118              (* we ignore the subst since restrict will take care of already
119               * instantiated/restricted metavariabels *)
120              let (metasenv,subst as ms), restrictions_for_n, l' =
121                let l = NCicUtils.expand_local_context lc in
122          
123                let ms, _, restrictions_for_n, l =
124                 List.fold_right
125                   (fun t (ms, i, restrictions_for_n, l) ->
126                     try 
127                       let ms, t = aux (k-shift) ms t in
128                       ms, i-1, restrictions_for_n, t::l
129                     with Occur ->
130                       ms, i-1, i::restrictions_for_n, l)
131                   l (ms, List.length l, [], [])
132                in
133                    
134                 ms, restrictions_for_n, pack_lc (shift, NCic.Ctx l)
135              in
136              if restrictions_for_n = [] then
137                ms, if l = l' then orig else NCic.Meta (n, l')
138              else
139                let metasenv, subst, newmeta = 
140                  restrict metasenv subst n restrictions_for_n 
141                in
142                  (metasenv, subst), NCic.Meta (newmeta, l'))
143     | t -> NCicUntrusted.map_term_fold_a (fun _ k -> k+1) k aux ms t
144  in
145    aux 0 (metasenv,subst) t 
146
147 and force_does_not_occur_in_context metasenv subst restrictions = function
148   | name, NCic.Decl t as orig ->
149       let (metasenv, subst), t' =
150         force_does_not_occur metasenv subst restrictions t in
151       metasenv, subst, (if t == t' then orig else (name,NCic.Decl t'))
152   | name, NCic.Def (bo, ty) as orig ->
153       let (metasenv, subst), bo' =
154         force_does_not_occur metasenv subst restrictions bo in
155       let (metasenv, subst), ty' =
156         force_does_not_occur metasenv subst restrictions ty in
157       metasenv, subst, 
158        (if bo == bo' && ty == ty' then orig else (name, NCic.Def (bo', ty')))
159
160 and erase_in_context metasenv subst pos restrictions = function
161   | [] -> metasenv, subst, restrictions, []
162   | hd::tl as orig ->
163       let metasenv, subst, restricted, tl' = 
164         erase_in_context metasenv subst (pos+1) restrictions tl in
165       if List.mem pos restricted then
166         metasenv, subst, restricted, tl'
167       else
168         try
169           let metasenv, subst, hd' =
170             let delifted_restricted = 
171               List.map ((+) ~-pos) (List.filter ((<=) pos) restricted) in
172             force_does_not_occur_in_context 
173               metasenv subst delifted_restricted hd
174           in
175            metasenv, subst, restricted, 
176             (if hd' == hd && tl' == tl then orig else (hd' :: tl'))
177         with Occur ->
178             metasenv, subst, (pos :: restricted), tl'
179
180 and restrict metasenv subst i restrictions =
181   assert (restrictions <> []);
182   try 
183     let name, ctx, bo, ty = NCicUtils.lookup_subst i subst in
184       try 
185         let metasenv, subst, restrictions, newctx = 
186           erase_in_context metasenv subst 1 restrictions ctx in
187         let (metasenv, subst), newty =  
188           force_does_not_occur metasenv subst restrictions ty in
189         let (metasenv, subst), newbo =  
190           force_does_not_occur metasenv subst restrictions bo in
191         let j = newmeta () in
192         let subst_entry_j = j, (name, newctx, newbo, newty) in
193         let reloc_irl = mk_perforated_irl 0 (List.length ctx) restrictions in
194         let subst_entry_i = i, (name, ctx, NCic.Meta (j, reloc_irl), ty) in
195         let new_subst = 
196           subst_entry_j :: List.map 
197             (fun (n,_) as orig -> if i = n then subst_entry_i else orig) subst
198         in
199 (*
200     prerr_endline ("restringo nella subst: " ^string_of_int i ^ " -> " ^ 
201       string_of_int j ^ "\n" ^ 
202       NCicPp.ppsubst ~metasenv [subst_entry_j] ^ "\n\n" ^
203       NCicPp.ppsubst ~metasenv [subst_entry_i] ^ "\n" ^
204       NCicPp.ppterm ~metasenv ~subst ~context:ctx bo ^ " ---- " ^
205       NCicPp.ppterm ~metasenv ~subst ~context:newctx newbo
206             );
207 *)
208         metasenv, new_subst, j
209       with Occur -> raise (MetaSubstFailure (lazy (Printf.sprintf
210             ("Cannot restrict the context of the metavariable ?%d over "^^
211             "the hypotheses %s since ?%d is already instantiated "^^
212             "with %s and at least one of the hypotheses occurs in "^^
213             "the substituted term") i  (String.concat ", " 
214             (List.map (fun x -> fst (List.nth ctx (x-1))) restrictions)) i
215             (NCicPp.ppterm ~metasenv ~subst ~context:ctx bo))))
216   with NCicUtils.Subst_not_found _ -> 
217     try 
218       let name, ctx, ty = NCicUtils.lookup_meta i metasenv in
219       try
220         let metasenv, subst, restrictions, newctx = 
221           erase_in_context metasenv subst 1 restrictions ctx in
222         let (metasenv, subst), newty =  
223           force_does_not_occur metasenv subst restrictions ty in
224         let j = newmeta () in
225         let metasenv_entry = j, (name, newctx, newty) in
226         let reloc_irl = 
227           mk_perforated_irl 0 (List.length ctx) restrictions in
228         let subst_entry = i, (name, ctx, NCic.Meta (j, reloc_irl), ty) in
229         List.map 
230           (fun (n,_) as orig -> if i = n then metasenv_entry else orig) 
231           metasenv,
232         subst_entry :: subst, j
233       with Occur -> raise (MetaSubstFailure (lazy (Printf.sprintf
234           ("Cannot restrict the context of the metavariable ?%d "^^
235           "over the hypotheses %s since metavariable's type depends "^^
236           "on at least one of them") i (String.concat ", " 
237           (List.map (fun x -> fst (List.nth ctx (x-1))) restrictions)))))
238     with 
239     | NCicUtils.Meta_not_found _ -> assert false
240 ;;
241
242 let rec flexible_arg context subst = function 
243   | NCic.Meta (i,_) ->
244       (try 
245         let _,_,t,_ = List.assoc i subst in
246         flexible_arg context subst t
247       with Not_found -> true)
248   | NCic.Appl (NCic.Meta (i,_) :: args)-> 
249       (try 
250         let _,_,t,_ = List.assoc i subst in
251         flexible_arg context subst 
252           (NCicReduction.head_beta_reduce ~delta:max_int 
253             (NCic.Appl (t :: args)))
254       with Not_found -> true)
255    (* this is a cheap whd, it only performs zeta-reduction.
256     * 
257     * it works when the **omissis** disambiguation algorithm
258     * is run on `let x := K a b in t`, K is substituted for a 
259     * ? and thus in t metavariables have a flexible Rel
260     *)
261   | NCic.Rel i ->
262       (try
263          match List.nth context (i-1)
264          with 
265          | _,NCic.Def (bo,_) ->
266                flexible_arg context subst
267                  (NCicSubstitution.lift i bo)
268          | _ -> false
269       with 
270       | Failure _ -> 
271           prerr_endline (Printf.sprintf "Rel %d inside context:\n%s" i  
272             (NCicPp.ppcontext ~subst ~metasenv:[] context));
273           assert false
274       | Invalid_argument _ -> assert false)
275   | _ -> false
276 ;;
277
278 let is_out_scope = function `OutScope _ -> true | _ -> false;;
279 let is_out_scope_tag = List.exists is_out_scope;;
280 let int_of_out_scope_tag tag = 
281  match List.filter is_out_scope tag with [`OutScope n] -> n | _ -> assert false
282 ;;
283
284
285 exception Found;;
286
287 (* INVARIANT: we suppose that t is not another occurrence of Meta(n,_), 
288    otherwise the occur check does not make sense in case of unification
289    of ?n with ?n *)
290 let delift ~unify metasenv subst context n l t =
291   (*D*)  inside 'D'; try let rc =  
292   let is_in_scope_meta subst = function
293     | NCic.Meta (i,_) ->
294         (try 
295            let tag, _, _, _ = NCicUtils.lookup_subst i subst in 
296             List.mem `InScope tag
297         with NCicUtils.Subst_not_found _ -> false)
298     | _ -> false
299   in
300   let contains_in_scope subst t = 
301     let rec aux _ () = function
302       | NCic.Meta _ as t ->
303           if is_in_scope_meta subst t then raise Found
304           else ()
305       | t -> 
306           if is_in_scope_meta subst t then raise Found
307           else NCicUtils.fold (fun _ () -> ()) () aux () t
308     in
309     try aux () () t; false with Found -> true
310   in
311   let unify_list in_scope = 
312     match l with
313     | _, NCic.Irl _ -> fun _ _ _ _ _ -> None
314     | shift, NCic.Ctx l -> fun metasenv subst context k t ->
315        if flexible_arg context subst t || contains_in_scope subst t then None else
316          let lb = 
317            List.map (fun t -> 
318             let t = NCicSubstitution.lift (k+shift) t in
319             t, flexible_arg context subst t) 
320            l 
321          in
322          HExtlib.list_findopt
323           (fun (li,flexible) i ->
324             if flexible || i < in_scope then None else
325              match unify metasenv subst context li t with
326              | Some (metasenv,subst) -> 
327                  Some ((metasenv, subst), NCic.Rel (i+1+k))
328              | None -> None)
329           lb
330   in
331   let rec aux (context,k,in_scope) (metasenv, subst as ms) t = 
332    match unify_list in_scope metasenv subst context k t with
333    | Some x -> x
334    | None -> 
335     match t with 
336     | NCic.Rel n as t when n <= k -> ms, t
337     | NCic.Rel n -> 
338         (try
339           match List.nth context (n-1) with
340           | _,NCic.Def (bo,_) -> 
341                 (try ms, NCic.Rel ((position in_scope (n-k) l) + k)
342                  with NotInTheList ->
343                 (* CSC: This bit of reduction hurts performances since it is
344                  * possible to  have an exponential explosion of the size of the
345                  * proof. required for nat/nth_prime.ma *)
346                   aux (context,k,in_scope) ms (NCicSubstitution.lift n bo))
347           | _,NCic.Decl _ -> ms, NCic.Rel ((position in_scope (n-k) l) + k)
348         with Failure _ -> assert false) (*Unbound variable found in delift*)
349     | NCic.Meta (i,_) when i=n ->
350          raise (MetaSubstFailure (lazy (Printf.sprintf (
351            "Cannot unify the metavariable ?%d with a term that has "^^
352            "as subterm %s in which the same metavariable "^^
353            "occurs (occur check)") i 
354             (NCicPp.ppterm ~context ~metasenv ~subst t))))
355     | NCic.Meta (i,l1) as orig ->
356         (try
357            let tag,c,t,ty = NCicUtils.lookup_subst i subst in
358            let in_scope, clear = 
359             if List.mem `InScope tag then 0, true
360             else if is_out_scope_tag tag then int_of_out_scope_tag tag,true
361             else in_scope, false
362            in
363            let ms = 
364              if not clear then ms
365              else 
366                metasenv, 
367                (i,([],c,t,ty)) :: List.filter (fun j,_ -> i <> j) subst
368            in
369            aux (context,k,in_scope) ms (NCicSubstitution.subst_meta l1 t)
370          with NCicUtils.Subst_not_found _ ->
371            if snd l1 = NCic.Irl 0 || snd l1 = NCic.Ctx [] then ms, orig
372            else
373               let shift1,lc1 = l1 in
374               let shift,lc = l in
375               let shift = shift + k in
376               match lc, lc1 with
377               | NCic.Irl len, NCic.Irl len1 
378                 when shift1 + len1 < shift || shift1 > shift + len ->
379                   let restrictions = HExtlib.list_seq 1 (len1 + 1) in
380                   let metasenv, subst, newmeta = 
381                      restrict metasenv subst i restrictions 
382                   in
383                   (metasenv, subst), 
384                     NCic.Meta (newmeta, (0,NCic.Irl (max 0 (k-shift1))))
385               | NCic.Irl len, NCic.Irl len1 ->
386                   let low_restrictions, new_shift = 
387                     if k <= shift1 && shift1 < shift then 
388                       HExtlib.list_seq 1 (shift - shift1 + 1), k
389                     else if shift1 < k (* <= shift *) then
390                       let save_below = k - shift1 in
391                       HExtlib.list_seq (save_below + 1) (shift - shift1 + 1),
392                       shift1
393                     else [], shift1 - shift + k
394                   in
395                   let high_restrictions = 
396                     let last = shift + len in
397                     let last1 = shift1 + len1 in
398                     if last1 > last then
399                       let high_gap = last1 - last in
400                       HExtlib.list_seq (len1 - high_gap + 1) (len1 + 1)
401                     else []
402                   in
403                   let restrictions = low_restrictions @ high_restrictions in
404                   if restrictions = [] then
405                     if shift = k then ms, orig
406                     else ms, NCic.Meta (i, (new_shift, lc1))
407                   else
408                     let metasenv, subst, newmeta = 
409                        restrict metasenv subst i restrictions
410                     in
411 (* {{{
412                   prerr_endline ("RESTRICTIONS FOR: " ^ 
413                     NCicPp.ppterm ~metasenv ~subst ~context:[] 
414                     (NCic.Meta (i,l1))^" that was part of a term unified with "
415                     ^ NCicPp.ppterm ~metasenv ~subst ~context:[] (NCic.Meta
416                     (n,l)) ^ " ====> " ^ String.concat "," (List.map
417                     string_of_int restrictions) ^ "\nMENV:\n" ^
418                     NCicPp.ppmetasenv ~subst metasenv ^ "\nSUBST:\n" ^
419                     NCicPp.ppsubst subst ~metasenv);
420 }}} *)
421                     let newlc_len = len1 - List.length restrictions in 
422                     let meta = 
423                        NCic.Meta(newmeta,(new_shift, NCic.Irl newlc_len))
424                     in
425                     assert (
426                       let _, cctx, _ = NCicUtils.lookup_meta newmeta metasenv in
427                       List.length cctx = newlc_len);
428                     (metasenv, subst), meta
429
430               | _ ->
431                   let lc1 = NCicUtils.expand_local_context lc1 in
432                   let lc1 = List.map (NCicSubstitution.lift shift1) lc1 in
433                   let rec deliftl tbr j ms = function
434                     | [] -> ms, tbr, []
435                     | t::tl ->
436                         let ms, tbr, tl = deliftl tbr (j+1) ms tl in
437                         try 
438                           let ms, t = aux (context,k,in_scope) ms t in 
439                           ms, tbr, t::tl
440                         with
441                         | NotInTheList | MetaSubstFailure _ -> ms, j::tbr, tl
442                   in
443                   let (metasenv, subst), to_be_r, lc1' = deliftl [] 1 ms lc1 in
444                   pp (lazy ("TO BE RESTRICTED: " ^ 
445                    (String.concat "," (List.map string_of_int to_be_r))));
446                   let l1 = pack_lc (0, NCic.Ctx lc1') in
447                   pp (lazy ("newmeta:" ^ NCicPp.ppterm
448                    ~metasenv ~subst ~context (NCic.Meta (999,l1))));
449                   pp (lazy (NCicPp.ppmetasenv ~subst metasenv));
450                   if to_be_r = [] then
451                     (metasenv, subst), 
452                     (if lc1' = lc1 then orig else NCic.Meta (i,l1))
453                   else
454                     let metasenv, subst, newmeta = 
455                       restrict metasenv subst i to_be_r in
456                     (metasenv, subst), NCic.Meta(newmeta,l1))
457
458     | t -> 
459         NCicUntrusted.map_term_fold_a 
460           (fun e (c,k,s) -> (e::c,k+1,s)) (context,k,in_scope) aux ms t
461   in
462 (*
463   prerr_endline (
464     "DELIFTO " ^ NCicPp.ppterm ~metasenv ~subst ~context t ^ " w.r.t. " ^
465     String.concat ", " (List.map (NCicPp.ppterm ~metasenv ~subst ~context) ( 
466       let shift, lc = l in
467       (List.map (NCicSubstitution.lift shift) 
468         (NCicUtils.expand_local_context lc))
469   )));
470 *)
471    try aux (context,0,0) (metasenv,subst) t
472    with NotInTheList ->
473       (* This is the case where we fail even first order unification. *)
474       (* The reason is that our delift function is weaker than first  *)
475       (* order (in the sense of alpha-conversion). See comment above  *)
476       (* related to the delift function.                              *)
477       let msg = (lazy (Printf.sprintf
478         ("Error trying to abstract %s over [%s]: the algorithm only tried to "^^
479         "abstract over bound variables") (NCicPp.ppterm ~metasenv ~subst
480         ~context t) (String.concat "; " (List.map (NCicPp.ppterm ~metasenv
481         ~subst ~context) (let shift, lc = l in List.map (NCicSubstitution.lift
482         shift) (NCicUtils.expand_local_context lc))))))
483       in
484       let shift, lc = l in
485       let lc = NCicUtils.expand_local_context lc in
486       let l = List.map (NCicSubstitution.lift shift) lc in
487        if
488         List.exists (fun t-> NCicUntrusted.metas_of_term subst context t <> [])l
489        then
490         raise (Uncertain msg)
491        else
492         raise (MetaSubstFailure msg)
493  (*D*)  in outside None; rc with exn -> outside (Some exn); raise exn 
494 ;;
495
496 let mk_meta ?(attrs=[]) metasenv context ?with_type kind = 
497   assert(kind <> `IsSort || context = []);
498   let n = newmeta () in
499   let ty= match with_type with None-> NCic.Implicit (`Typeof n)| Some x ->x in
500   let len = List.length context in
501   let attrs = NCicUntrusted.set_kind kind attrs in
502   let menv_entry = (n, (attrs, context, ty)) in
503   menv_entry :: metasenv, n, NCic.Meta (n, (0,NCic.Irl len)), ty
504 ;;
505
506 let extend_meta metasenv n =
507  try
508   let attrs,cc,ty = NCicUtils.lookup_meta n metasenv in 
509   (match ty with 
510   | NCic.Implicit (`Typeof _) -> 
511       let mk_meta context kind =
512         let metasenv, _, ty, _ = mk_meta metasenv context kind in
513         (n, (attrs, cc, ty)) :: List.filter (fun x,_ -> x <> n) metasenv, ty
514       in
515       (match NCicUntrusted.kind_of_meta attrs with
516        | `IsSort 
517        | `IsType -> mk_meta [] `IsSort
518        | `IsTerm -> mk_meta cc `IsType)
519   | ty -> metasenv, ty)
520  with NCicUtils.Meta_not_found _ -> assert false
521 ;;
522
523 let saturate ?(delta=0) metasenv subst context ty goal_arity =
524  assert (goal_arity >= 0);
525   let rec aux metasenv = function
526    | NCic.Prod (name,s,t) as ty ->
527        let metasenv1, _, arg,_ = 
528           mk_meta ~attrs:[`Name name] metasenv context ~with_type:s `IsTerm in
529        let t, metasenv1, args, pno = 
530            aux metasenv1 (NCicSubstitution.subst arg t) 
531        in
532        if pno + 1 = goal_arity then
533          ty, metasenv, [], goal_arity+1
534        else
535          t, metasenv1, arg::args, pno+1
536    | ty ->
537         match NCicReduction.whd ~subst context ty ~delta with
538         | NCic.Prod _ as ty -> aux metasenv ty
539         | ty -> ty, metasenv, [], 0
540   in
541   let res, newmetasenv, arguments, _ = aux metasenv ty in
542   res, newmetasenv, arguments
543 ;;