1 (* Copyright (C) 2000, HELM Team.
3 * This file is part of HELM, an Hypertextual, Electronic
4 * Library of Mathematics, developed at the Computer Science
5 * Department, University of Bologna, Italy.
7 * HELM is free software; you can redistribute it and/or
8 * modify it under the terms of the GNU General Public License
9 * as published by the Free Software Foundation; either version 2
10 * of the License, or (at your option) any later version.
12 * HELM is distributed in the hope that it will be useful,
13 * but WITHOUT ANY WARRANTY; without even the implied warranty of
14 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 * GNU General Public License for more details.
17 * You should have received a copy of the GNU General Public License
18 * along with HELM; if not, write to the Free Software
19 * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
22 * For details, see the HELM World-Wide-Web page,
23 * http://cs.unibo.it/helm/.
26 (*****************************************************************************)
30 (* Claudio Sacerdoti Coen <sacerdot@cs.unibo.it> *)
33 (* This module implements a trival cache system (an hash-table) for cic *)
34 (* objects. Uses the getter (getter.ml) and the parser (cicParser.ml) *)
36 (*****************************************************************************)
39 let cleanup_tmp = true;;
41 let trust = ref (fun _ -> true);;
42 let set_trust f = trust := f
43 let trust_obj uri = !trust uri
45 type type_checked_obj =
46 CheckedObj of (Cic.obj * CicUniv.universe_graph) (* cooked obj *)
47 | UncheckedObj of Cic.obj (* uncooked obj to proof-check *)
51 exception AlreadyCooked of string;;
52 exception CircularDependency of string;;
53 exception CouldNotFreeze of string;;
54 exception CouldNotUnfreeze of string;;
55 exception Term_not_found of UriManager.uri;;
57 (* Cache that uses == instead of = for testing equality *)
58 (* Invariant: an object is always in at most one of the *)
59 (* following states: unchecked, frozen and cooked. *)
62 val find_or_add_unchecked :
64 get_object_to_add:(unit -> Cic.obj * CicUniv.universe_graph option) ->
65 Cic.obj * CicUniv.universe_graph
67 UriManager.uri -> bool
68 val unchecked_to_frozen :
69 UriManager.uri -> unit
70 val frozen_to_cooked :
71 uri:UriManager.uri -> unit
73 UriManager.uri -> CicUniv.universe_graph -> unit
75 key:UriManager.uri -> Cic.obj * CicUniv.universe_graph
77 key:UriManager.uri -> (Cic.obj * CicUniv.universe_graph) -> unit
79 UriManager.uri -> Cic.obj * CicUniv.universe_graph
80 val remove: UriManager.uri -> unit
82 val dump_to_channel : ?callback:(string -> unit) -> out_channel -> unit
83 val restore_from_channel : ?callback:(string -> unit) -> in_channel -> unit
84 val empty : unit -> unit
85 val is_in_frozen: UriManager.uri -> bool
86 val is_in_unchecked: UriManager.uri -> bool
90 (*************************************************************************
92 The CacheOfCookedObjects will contain only objects with a valid universe
93 graph. valid means that non None (used if there is no universe file
94 in the universe generation phase).
95 **************************************************************************)
96 module CacheOfCookedObjects :
98 val mem : UriManager.uri -> bool
99 val find : UriManager.uri -> Cic.obj * CicUniv.universe_graph
100 val add : UriManager.uri -> (Cic.obj * CicUniv.universe_graph) -> unit
101 val remove : UriManager.uri -> unit
103 (** (de)serialization of type checker cache *)
104 val dump_to_channel : ?callback:(string -> unit) -> out_channel -> unit
105 val restore_from_channel : ?callback:(string -> unit) -> in_channel -> unit
106 val empty : unit -> unit
112 type t = UriManager.uri
113 let equal = UriManager.eq
114 let hash = Hashtbl.hash
117 module HT = Hashtbl.Make(HashedType);;
118 let hashtable = HT.create 1009;;
125 let find uri = HT.find hashtable uri ;;
126 let add uri (obj,ugraph) =
127 HT.add hashtable uri (obj,ugraph)
131 HT.remove hashtable uri
133 raise (Term_not_found uri);
136 (* used to hash cons uris on restore to grant URI structure unicity *)
138 let module C = Cic in
140 UriManager.uri_of_string (UriManager.string_of_uri uri)
142 let rec restore_in_term =
145 | C.Var (uri,exp_named_subst) ->
146 let uri' = recons uri in
147 let exp_named_subst' =
149 (function (uri,t) ->(recons uri,restore_in_term t))
152 C.Var (uri',exp_named_subst')
158 | Some t -> Some (restore_in_term t)
163 | C.Implicit _ as t -> t
164 | C.Cast (te,ty) -> C.Cast (restore_in_term te, restore_in_term ty)
165 | C.Prod (n,s,t) -> C.Prod (n, restore_in_term s, restore_in_term t)
166 | C.Lambda (n,s,t) -> C.Lambda (n, restore_in_term s, restore_in_term t)
167 | C.LetIn (n,s,t) -> C.LetIn (n, restore_in_term s, restore_in_term t)
168 | C.Appl l -> C.Appl (List.map restore_in_term l)
169 | C.Const (uri,exp_named_subst) ->
170 let uri' = recons uri in
171 let exp_named_subst' =
173 (function (uri,t) -> (recons uri,restore_in_term t)) exp_named_subst
175 C.Const (uri',exp_named_subst')
176 | C.MutInd (uri,tyno,exp_named_subst) ->
177 let uri' = recons uri in
178 let exp_named_subst' =
180 (function (uri,t) -> (recons uri,restore_in_term t)) exp_named_subst
182 C.MutInd (uri',tyno,exp_named_subst')
183 | C.MutConstruct (uri,tyno,consno,exp_named_subst) ->
184 let uri' = recons uri in
185 let exp_named_subst' =
187 (function (uri,t) -> (recons uri,restore_in_term t)) exp_named_subst
189 C.MutConstruct (uri',tyno,consno,exp_named_subst')
190 | C.MutCase (uri,i,outty,t,pl) ->
191 C.MutCase (recons uri, i, restore_in_term outty, restore_in_term t,
192 List.map restore_in_term pl)
194 let len = List.length fl in
197 (fun (name, i, ty, bo) ->
198 (name, i, restore_in_term ty, restore_in_term bo))
203 let len = List.length fl in
206 (fun (name, ty, bo) -> (name, restore_in_term ty, restore_in_term bo))
209 C.CoFix (i, liftedfl)
212 C.Constant (name,bo,ty,params) ->
216 | Some bo -> Some (restore_in_term bo)
218 let ty' = restore_in_term ty in
219 let params' = List.map recons params in
220 C.Constant (name, bo', ty', params')
221 | C.CurrentProof (name,conjs,bo,ty,params) ->
224 (function (i,hyps,ty) ->
228 | Some (name,C.Decl t) ->
229 Some (name,C.Decl (restore_in_term t))
230 | Some (name,C.Def (bo,ty)) ->
234 | Some ty'' -> Some (restore_in_term ty'')
236 Some (name,C.Def (restore_in_term bo, ty'))) hyps,
240 let bo' = restore_in_term bo in
241 let ty' = restore_in_term ty in
242 let params' = List.map recons params in
243 C.CurrentProof (name, conjs', bo', ty', params')
244 | C.Variable (name,bo,ty,params) ->
248 | Some bo -> Some (restore_in_term bo)
250 let ty' = restore_in_term ty in
251 let params' = List.map recons params in
252 C.Variable (name, bo', ty', params')
253 | C.InductiveDefinition (tl,params,paramsno) ->
254 let params' = List.map recons params in
256 List.map (function (name, inductive, ty, constructors) ->
261 (function (name, ty) -> name, restore_in_term ty)
265 C.InductiveDefinition (tl', params', paramsno)
267 let dump_to_channel ?(callback = ignore) oc =
268 HT.iter (fun uri _ -> callback (UriManager.string_of_uri uri)) hashtable;
269 Marshal.to_channel oc hashtable [] ;;
270 let empty () = HT.clear hashtable ;;
271 let restore_from_channel ?(callback = ignore) ic =
272 let restored = Marshal.from_channel ic in
276 callback (UriManager.string_of_uri k);
278 (UriManager.uri_of_string (UriManager.string_of_uri k))
280 (************************************************
281 TASSI: FIXME add channel stuff for universes
282 *************************************************)
284 ((restore_uris v),CicUniv.empty_ugraph))
290 let frozen_list = ref [];;
291 let unchecked_list = ref [];;
293 let is_in_frozen uri =
294 List.mem_assoc uri !frozen_list
297 let is_in_unchecked uri =
298 List.mem_assoc uri !unchecked_list
300 (*******************************************************************
302 we need, in the universe generation phase, to traverse objects
303 that are not jet committed, so we search them in the frozen list.
304 Only uncommitted objects without a universe file (see the assertion)
305 can be searched with method
306 *******************************************************************)
307 let not_jet_cooked uri =
309 let o,u = List.assoc uri !frozen_list in
311 None -> o, CicUniv.empty_ugraph
312 | Some _ -> assert false (* only univ_maker ca use this *)
314 CacheOfCookedObjects.find uri
316 let find_or_add_unchecked uri ~get_object_to_add =
318 let o,g = List.assq uri !unchecked_list in
320 None -> o,CicUniv.empty_ugraph
324 if List.mem_assq uri !frozen_list then
326 print_endline "\nCircularDependency!\nfrozen list: \n";
329 let su = UriManager.string_of_uri u in
330 let univ = if o = None then "NO_UNIV" else "" in
331 print_endline (su^" "^univ))
333 raise (CircularDependency (UriManager.string_of_uri uri))
336 if CacheOfCookedObjects.mem uri then
337 raise (AlreadyCooked (UriManager.string_of_uri uri))
339 (* OK, it is not already frozen nor cooked *)
340 let obj,ugraph = get_object_to_add () in
343 None -> CicUniv.empty_ugraph
346 unchecked_list := (uri,(obj,ugraph))::!unchecked_list ;
349 let unchecked_to_frozen uri =
351 let obj,ugraph = List.assq uri !unchecked_list in
352 unchecked_list := List.remove_assq uri !unchecked_list ;
353 frozen_list := (uri,(obj,ugraph))::!frozen_list
355 Not_found -> raise (CouldNotFreeze (UriManager.string_of_uri uri))
357 (************************************************************
359 only object with a valid universe graph can be committed
360 *************************************************************)
361 let frozen_to_cooked ~uri =
363 let obj,ugraph = List.assq uri !frozen_list in
366 assert false (* only non dummy universes can be committed *)
368 frozen_list := List.remove_assq uri !frozen_list ;
369 CacheOfCookedObjects.add uri (obj,g)
371 Not_found -> raise (CouldNotUnfreeze (UriManager.string_of_uri uri))
373 let can_be_cooked uri =
375 let obj,ugraph = List.assq uri !frozen_list in
382 let hack_univ uri real_ugraph =
384 let o,g = List.assq uri !frozen_list in
387 frozen_list := List.remove_assoc uri !frozen_list;
388 frozen_list := (uri,(o,Some real_ugraph))::!frozen_list;
391 "You are probably hacking an object already hacked or an"^
392 " object that has the universe file but is not"^
398 "You are hacking an object that is not in the"^
399 " frozen_list, this means you are probably generating an"^
400 " universe file for an object that already as an universe file");
403 let find_cooked ~key:uri = CacheOfCookedObjects.find uri;;
404 let add_cooked ~key:uri (obj,ugraph) =
405 CacheOfCookedObjects.add uri (obj,ugraph);;
407 if (!unchecked_list <> []) || (!frozen_list <> []) then
408 failwith "CicEnvironment.remove while type checking"
410 CacheOfCookedObjects.remove uri
412 let dump_to_channel = CacheOfCookedObjects.dump_to_channel;;
413 let restore_from_channel = CacheOfCookedObjects.restore_from_channel;;
415 CacheOfCookedObjects.empty ();
416 unchecked_list := [] ;
422 let dump_to_channel = Cache.dump_to_channel;;
423 let restore_from_channel = Cache.restore_from_channel;;
424 let empty = Cache.empty;;
426 let find_or_add_unchecked_to_cache uri =
427 Cache.find_or_add_unchecked uri
430 let filename = Http_getter.getxml' uri in
432 match UriManager.bodyuri_of_uri uri with
436 ignore (Http_getter.resolve' bodyuri) ;
437 (* The body exists ==> it is not an axiom *)
438 Some (Http_getter.getxml' bodyuri)
440 Http_getter_types.Key_not_found _ ->
441 (* The body does not exist ==> we consider it an axiom *)
446 maybe this is not the right place to do this.. but I think
447 obj_of_xml is called only here
449 (* this brakes something : let _ = CicUniv.restart_numbering () in *)
450 let obj = CicParser.obj_of_xml filename bodyfilename in
451 let ugraph,filename_univ =
455 Http_getter.getxml' (
456 UriManager.uri_of_string (
457 (UriManager.string_of_uri uri) ^ ".univ"))
459 (Some (CicUniv.ugraph_of_xml filename_univ),Some filename_univ)
463 "WE HAVE NO UNIVERSE FILE FOR " ^ (UriManager.string_of_uri uri));
466 (**********************************************
467 TASSI: should fail when universes will be ON
468 ***********************************************)
469 (Some CicUniv.empty_ugraph,None)
472 Unix.unlink filename ;
474 match filename_univ with
475 Some f -> Unix.unlink f
479 match bodyfilename with
480 Some f -> Unix.unlink f
488 (* set_type_checking_info uri *)
489 (* must be called once the type-checking of uri is finished *)
490 (* The object whose uri is uri is unfreezed *)
491 let set_type_checking_info ?(replace_ugraph=None) uri =
492 if Cache.can_be_cooked uri && replace_ugraph <> None then
494 "?replace_ugraph must be None if you are not committing an "^
495 "object that has an no universe graph associated "^
496 "(can happen only in the fase of universes graphs generation).");
497 if not (Cache.can_be_cooked uri) && replace_ugraph = None then
499 "?replace_ugraph must be (Some ugraph) when committing an object that "^
500 "has no associated universe graph. If this is in make_univ phase you "^
501 "should drop this exception and let univ_make commit thi object with "^
504 match replace_ugraph with
506 | Some g -> Cache.hack_univ uri g
508 Cache.frozen_to_cooked uri
512 (* is_type_checked uri *)
513 (* CSC: commento falso ed obsoleto *)
514 (* returns a CheckedObj if the term has been type-checked *)
515 (* otherwise it freezes the term for type-checking and returns
517 (* set_type_checking_info must be called to unfreeze the term *)
518 let is_type_checked ?(trust=true) uri base_univ =
520 let o,u = Cache.find_cooked uri in
521 CheckedObj (o,CicUniv.merge_ugraphs u base_univ)
524 let obj,ugraph = find_or_add_unchecked_to_cache uri in
525 Cache.unchecked_to_frozen uri ;
526 if trust && trust_obj uri then
528 CicLogger.log (`Trusting uri) ;
529 set_type_checking_info uri ;
530 let o,u = Cache.find_cooked uri in
531 let u' = CicUniv.merge_ugraphs base_univ ugraph in
540 (* get_cooked_obj ~trust uri *)
541 (* returns the object if it is already type-checked or if it can be *)
542 (* trusted (if [trust] = true and the trusting function accepts it) *)
543 (* Otherwise it raises Not_found *)
544 let get_cooked_obj ?(trust=true) uri base_univ =
546 let o,u = Cache.find_cooked uri in
547 o,(CicUniv.merge_ugraphs base_univ u)
549 if trust && trust_obj uri then
551 match is_type_checked uri base_univ with
552 CheckedObj (obj,ugraph) -> obj,(CicUniv.merge_ugraphs ugraph base_univ)
558 "@@@ OOOOOOOPS: get_cooked_obj(" ^ UriManager.string_of_uri uri ^
559 ") raises Not_found since the object is not type-checked"^
566 (* returns the cic object whose uri is uri. If the term is not just in cache,*)
567 (* then it is parsed via CicParser.term_of_xml from the file whose name is *)
568 (* the result of Getter.getxml uri *)
569 let get_obj ?(not_jet_cooked=false) uri base_univ =
570 if not_jet_cooked then
571 let o,u = Cache.not_jet_cooked uri in
572 o,(CicUniv.merge_ugraphs base_univ u)
575 get_cooked_obj uri base_univ
578 let s = ( UriManager.string_of_uri uri) in
579 let o,u = find_or_add_unchecked_to_cache uri in
580 o,(CicUniv.merge_ugraphs base_univ u)
583 exception OnlyPutOfInductiveDefinitionsIsAllowed
585 let put_inductive_definition uri (obj,ugraph) =
587 Cic.InductiveDefinition _ -> Cache.add_cooked uri (obj,ugraph)
588 | _ -> raise OnlyPutOfInductiveDefinitionsIsAllowed
593 ignore (Cache.find_cooked uri);
594 prerr_endline "TROVATO NELLA CHECKED";true
596 if Cache.is_in_frozen uri then
597 (prerr_endline "TROVATO NELLA FROZEN";true)
599 if Cache.is_in_unchecked uri then
600 (prerr_endline "TROVATO NELLA UNCHECKED";true)
602 (prerr_endline ("NON TROVATO:" ^ (UriManager.string_of_uri uri) );false)
605 let add_type_checked_term uri (obj,ugraph) =
607 Cic.Constant (s,(Some bo),ty,ul) ->
608 Cache.add_cooked ~key:uri (obj,ugraph)
613 let remove_term = Cache.remove