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 (* ************************************************************************** *
40 CicEnvironment SETTINGS (trust and clean_tmp)
41 * ************************************************************************** *)
43 let cleanup_tmp = true;;
44 let trust = ref (fun _ -> true);;
45 let set_trust f = trust := f
46 let trust_obj uri = !trust uri
49 (* ************************************************************************** *
51 * ************************************************************************** *)
53 type type_checked_obj =
54 CheckedObj of (Cic.obj * CicUniv.universe_graph) (* cooked obj *)
55 | UncheckedObj of Cic.obj (* uncooked obj to proof-check *)
58 exception AlreadyCooked of string;;
59 exception CircularDependency of string;;
60 exception CouldNotFreeze of string;;
61 exception CouldNotUnfreeze of string;;
62 exception Object_not_found of UriManager.uri;;
65 (* ************************************************************************** *
66 HERE STARTS THE CACHE MODULE
67 * ************************************************************************** *)
69 (* I think this should be the right place to implement mecanisms and
73 (* Cache that uses == instead of = for testing equality *)
74 (* Invariant: an object is always in at most one of the *)
75 (* following states: unchecked, frozen and cooked. *)
78 val find_or_add_to_unchecked :
81 (UriManager.uri -> Cic.obj * CicUniv.universe_graph option) ->
82 Cic.obj * CicUniv.universe_graph
84 UriManager.uri -> bool
85 val unchecked_to_frozen :
86 UriManager.uri -> unit
87 val frozen_to_cooked :
88 uri:UriManager.uri -> unit
90 UriManager.uri -> CicUniv.universe_graph -> unit
92 key:UriManager.uri -> Cic.obj * CicUniv.universe_graph
94 key:UriManager.uri -> (Cic.obj * CicUniv.universe_graph) -> unit
95 val remove: UriManager.uri -> unit
96 val dump_to_channel : ?callback:(string -> unit) -> out_channel -> unit
97 val restore_from_channel : ?callback:(string -> unit) -> in_channel -> unit
98 val empty : unit -> unit
99 val is_in_frozen: UriManager.uri -> bool
100 val is_in_unchecked: UriManager.uri -> bool
101 val is_in_cooked: UriManager.uri -> bool
102 val list_all_cooked_uris: unit -> UriManager.uri list
106 (*************************************************************************
108 The cacheOfCookedObjects will contain only objects with a valid universe
109 graph. valid means that not None (used if there is no universe file
110 in the universe generation phase).
111 **************************************************************************)
113 (* DATA: the data structure that implements the CACHE *)
116 type t = UriManager.uri
117 let equal = UriManager.eq
118 let hash = Hashtbl.hash
122 module HT = Hashtbl.Make(HashedType);;
124 let cacheOfCookedObjects = HT.create 1009;;
126 (* DATA: The parking lists
127 * the lists elements are (uri * (obj * universe_graph option))
128 * ( u, ( o, None )) means that the object has no universes file, this
129 * should happen only in the universe generation phase.
130 * FIXME: if the universe generation is integrated in the library
131 * exportation phase, the 'option' MUST be removed.
132 * ( u, ( o, Some g)) means that the object has a universes file,
136 (* frozen is used to detect circular dependency. *)
137 let frozen_list = ref [];;
138 (* unchecked is used to store objects just fetched, nothing more. *)
139 let unchecked_list = ref [];;
141 (* FIXED: should be ok even if not touched *)
142 (* used to hash cons uris on restore to grant URI structure unicity *)
144 let module C = Cic in
146 UriManager.uri_of_string (UriManager.string_of_uri uri)
148 let rec restore_in_term =
151 | C.Var (uri,exp_named_subst) ->
152 let uri' = recons uri in
153 let exp_named_subst' =
155 (function (uri,t) ->(recons uri,restore_in_term t))
158 C.Var (uri',exp_named_subst')
164 | Some t -> Some (restore_in_term t)
169 | C.Implicit _ as t -> t
170 | C.Cast (te,ty) -> C.Cast (restore_in_term te, restore_in_term ty)
171 | C.Prod (n,s,t) -> C.Prod (n, restore_in_term s, restore_in_term t)
172 | C.Lambda (n,s,t) -> C.Lambda (n, restore_in_term s, restore_in_term t)
173 | C.LetIn (n,s,t) -> C.LetIn (n, restore_in_term s, restore_in_term t)
174 | C.Appl l -> C.Appl (List.map restore_in_term l)
175 | C.Const (uri,exp_named_subst) ->
176 let uri' = recons uri in
177 let exp_named_subst' =
179 (function (uri,t) -> (recons uri,restore_in_term t)) exp_named_subst
181 C.Const (uri',exp_named_subst')
182 | C.MutInd (uri,tyno,exp_named_subst) ->
183 let uri' = recons uri in
184 let exp_named_subst' =
186 (function (uri,t) -> (recons uri,restore_in_term t)) exp_named_subst
188 C.MutInd (uri',tyno,exp_named_subst')
189 | C.MutConstruct (uri,tyno,consno,exp_named_subst) ->
190 let uri' = recons uri in
191 let exp_named_subst' =
193 (function (uri,t) -> (recons uri,restore_in_term t)) exp_named_subst
195 C.MutConstruct (uri',tyno,consno,exp_named_subst')
196 | C.MutCase (uri,i,outty,t,pl) ->
197 C.MutCase (recons uri, i, restore_in_term outty, restore_in_term t,
198 List.map restore_in_term pl)
200 let len = List.length fl in
203 (fun (name, i, ty, bo) ->
204 (name, i, restore_in_term ty, restore_in_term bo))
209 let len = List.length fl in
212 (fun (name, ty, bo) -> (name, restore_in_term ty, restore_in_term bo))
215 C.CoFix (i, liftedfl)
218 C.Constant (name,bo,ty,params,attrs) ->
222 | Some bo -> Some (restore_in_term bo)
224 let ty' = restore_in_term ty in
225 let params' = List.map recons params in
226 C.Constant (name, bo', ty', params',attrs)
227 | C.CurrentProof (name,conjs,bo,ty,params,attrs) ->
230 (function (i,hyps,ty) ->
234 | Some (name,C.Decl t) ->
235 Some (name,C.Decl (restore_in_term t))
236 | Some (name,C.Def (bo,ty)) ->
240 | Some ty'' -> Some (restore_in_term ty'')
242 Some (name,C.Def (restore_in_term bo, ty'))) hyps,
246 let bo' = restore_in_term bo in
247 let ty' = restore_in_term ty in
248 let params' = List.map recons params in
249 C.CurrentProof (name, conjs', bo', ty', params',attrs)
250 | C.Variable (name,bo,ty,params,attrs) ->
254 | Some bo -> Some (restore_in_term bo)
256 let ty' = restore_in_term ty in
257 let params' = List.map recons params in
258 C.Variable (name, bo', ty', params',attrs)
259 | C.InductiveDefinition (tl,params,paramsno,attrs) ->
260 let params' = List.map recons params in
262 List.map (function (name, inductive, ty, constructors) ->
267 (function (name, ty) -> name, restore_in_term ty)
271 C.InductiveDefinition (tl', params', paramsno, attrs)
275 HT.clear cacheOfCookedObjects;
276 unchecked_list := [] ;
280 (* FIX: universe stuff?? *)
281 let dump_to_channel ?(callback = ignore) oc =
282 HT.iter (fun uri _ -> callback (UriManager.string_of_uri uri))
283 cacheOfCookedObjects;
284 Marshal.to_channel oc cacheOfCookedObjects []
287 (* FIX: universes stuff?? *)
288 let restore_from_channel ?(callback = ignore) ic =
289 let restored = Marshal.from_channel ic in
290 (* FIXME: should this empty clean the frozen and unchecked?
291 * if not, the only-one-empty-end-not-3 patch is wrong
296 callback (UriManager.string_of_uri k);
297 HT.add cacheOfCookedObjects
298 (UriManager.uri_of_string (UriManager.string_of_uri k))
299 (***********************************************
300 TSSI: FIXME add channel stuff for universes
301 ************************************************)
302 ((restore_uris v),CicUniv.empty_ugraph))
307 let is_in_frozen uri =
308 List.mem_assoc uri !frozen_list
311 let is_in_unchecked uri =
312 List.mem_assoc uri !unchecked_list
315 let is_in_cooked uri =
316 HT.mem cacheOfCookedObjects uri
320 (*******************************************************************
322 we need, in the universe generation phase, to traverse objects
323 that are not jet committed, so we search them in the frozen list.
324 Only uncommitted objects without a universe file (see the assertion)
325 can be searched with method
326 *******************************************************************)
328 let find_or_add_to_unchecked uri ~get_object_to_add =
330 let o,g = List.assq uri !unchecked_list in
332 (* FIXME: we accept both cases, as at the end of this function
333 * maybe the None universe outside the cache module should be
336 * another thing that should be removed if univ generation phase
337 * and lib exportation are unified.
339 None -> o,CicUniv.empty_ugraph
343 if List.mem_assq uri !frozen_list then
344 (* CIRCULAR DEPENDENCY DETECTED, print the error and raise *)
346 print_endline "\nCircularDependency!\nfrozen list: \n";
349 let su = UriManager.string_of_uri u in
350 let univ = if o = None then "NO_UNIV" else "" in
351 print_endline (su^" "^univ))
353 raise (CircularDependency (UriManager.string_of_uri uri))
356 if HT.mem cacheOfCookedObjects uri then
357 (* DOUBLE COOK DETECTED, raise the exception *)
358 raise (AlreadyCooked (UriManager.string_of_uri uri))
360 (* OK, it is not already frozen nor cooked *)
361 let obj,ugraph = get_object_to_add uri in
364 (* FIXME: not sure it is OK*)
365 None -> CicUniv.empty_ugraph
368 unchecked_list := (uri,(obj,ugraph))::!unchecked_list ;
372 let unchecked_to_frozen uri =
374 let obj,ugraph = List.assq uri !unchecked_list in
375 unchecked_list := List.remove_assq uri !unchecked_list ;
376 frozen_list := (uri,(obj,ugraph))::!frozen_list
378 Not_found -> raise (CouldNotFreeze (UriManager.string_of_uri uri))
382 (************************************************************
384 only object with a valid universe graph can be committed
386 this should disappear if the universe generation phase and the
387 library exportation are unified.
388 *************************************************************)
389 let frozen_to_cooked ~uri =
391 let obj,ugraph = List.assq uri !frozen_list in
394 assert false (* only NON dummy universes can be committed *)
396 frozen_list := List.remove_assq uri !frozen_list ;
397 HT.add cacheOfCookedObjects uri (obj,g)
399 Not_found -> raise (CouldNotUnfreeze (UriManager.string_of_uri uri))
402 let can_be_cooked uri =
404 let obj,ugraph = List.assq uri !frozen_list in
405 (* FIXME: another thing to remove if univ generation phase and lib
406 * exportation are unified.
415 (* this function injects a real universe graph in a (uri, (obj, None))
416 * element of the frozen list.
418 * FIXME: another thing to remove if univ generation phase and lib
419 * exportation are unified.
421 let hack_univ uri real_ugraph =
423 let o,g = List.assq uri !frozen_list in
426 frozen_list := List.remove_assoc uri !frozen_list;
427 frozen_list := (uri,(o,Some real_ugraph))::!frozen_list;
430 "You are probably hacking an object already hacked or an"^
431 " object that has the universe file but is not"^
437 "You are hacking an object that is not in the"^
438 " frozen_list, this means you are probably generating an"^
439 " universe file for an object that already"^
440 " as an universe file");
444 let find_cooked ~key:uri = HT.find cacheOfCookedObjects uri ;;
446 let add_cooked ~key:uri (obj,ugraph) =
447 HT.add cacheOfCookedObjects uri (obj,ugraph)
452 * an object can be romeved from the cache only if we are not typechecking
453 * something. this means check and frozen must be empty.
456 if (!unchecked_list <> []) || (!frozen_list <> []) then
457 failwith "CicEnvironment.remove while type checking"
459 HT.remove cacheOfCookedObjects uri
462 let list_all_cooked_uris () =
463 HT.fold (fun u _ l -> u::l) cacheOfCookedObjects []
469 (* ************************************************************************
470 HERE ENDS THE CACHE MODULE
471 * ************************************************************************ *)
473 (* exported cache functions *)
474 let dump_to_channel = Cache.dump_to_channel;;
475 let restore_from_channel = Cache.restore_from_channel;;
476 let empty = Cache.empty;;
478 let get_object_to_add uri =
479 let filename = Http_getter.getxml' uri in
481 match UriManager.bodyuri_of_uri uri with
485 ignore (Http_getter.resolve' bodyuri) ;
486 (* The body exists ==> it is not an axiom *)
487 Some (Http_getter.getxml' bodyuri)
489 Http_getter_types.Key_not_found _ ->
490 (* The body does not exist ==> we consider it an axiom *)
494 Unix.unlink filename ;
497 match filename_univ with
498 Some f -> Unix.unlink f
503 match bodyfilename with
504 Some f -> Unix.unlink f
508 (* this brakes something :
509 * let _ = CicUniv.restart_numbering () in
513 CicParser.obj_of_xml filename bodyfilename
517 | CicParser.Getter_failure ("key_not_found", uri) ->
518 raise (Object_not_found (UriManager.uri_of_string uri))
521 let ugraph,filename_univ =
522 (* FIXME: decomment this when the universes will be part of the library
525 Http_getter.getxml' (
526 UriManager.uri_of_string (
527 (UriManager.string_of_uri uri) ^ ".univ"))
529 (Some (CicUniv.ugraph_of_xml filename_univ),Some filename_univ)
533 "WE HAVE NO UNIVERSE FILE FOR " ^ (UriManager.string_of_uri uri));
537 (**********************************************
538 TASSI: should fail when universes will be ON
539 ***********************************************)
540 (Some CicUniv.empty_ugraph,None)
546 (* this is the function to fetch the object in the unchecked list and
547 * nothing more (except returning it)
549 let find_or_add_to_unchecked uri =
550 Cache.find_or_add_to_unchecked uri ~get_object_to_add
552 (* set_type_checking_info uri *)
553 (* must be called once the type-checking of uri is finished *)
554 (* The object whose uri is uri is unfreezed *)
556 (* the replacement ugraph must be the one returned by the *)
557 (* typechecker, restricted with the CicUnivUtils.clean_and_fill *)
558 let set_type_checking_info ?(replace_ugraph=None) uri =
559 if Cache.can_be_cooked uri && replace_ugraph <> None then
561 "?replace_ugraph must be None if you are not committing an "^
562 "object that has a universe graph associated "^
563 "(can happen only in the fase of universes graphs generation).");
564 if not (Cache.can_be_cooked uri) && replace_ugraph = None then
566 "?replace_ugraph must be (Some ugraph) when committing an object that "^
567 "has no associated universe graph. If this is in make_univ phase you "^
568 "should drop this exception and let univ_make commit thi object with "^
571 match replace_ugraph with
573 | Some g -> Cache.hack_univ uri g
575 Cache.frozen_to_cooked uri
578 (* fetch, unfreeze and commit an uri to the cacheOfCookedObjects and
579 * return the object,ugraph
581 let add_trusted_uri_to_cache uri =
582 let o,u = find_or_add_to_unchecked uri in
583 Cache.unchecked_to_frozen uri;
584 set_type_checking_info uri;
586 Cache.find_cooked uri
587 with Not_found -> assert false
590 (* get the uri, if we trust it will be added to the cacheOfCookedObjects *)
591 let get_cooked_obj ?(trust=true) base_univ uri =
593 (* the object should be in the cacheOfCookedObjects *)
594 let o,u = Cache.find_cooked uri in
595 o,(CicUniv.merge_ugraphs base_univ u)
597 (* this should be an error case, but if we trust the uri... *)
598 if trust && trust_obj uri then
599 (* trusting means that we will fetch cook it on the fly *)
600 let o,u = add_trusted_uri_to_cache uri in
601 o,(CicUniv.merge_ugraphs base_univ u)
603 (* we don't trust the uri, so we fail *)
605 prerr_endline ("CACHE MISS: " ^ (UriManager.string_of_uri uri));
609 (* This has not the old semantic :( but is what the name suggests
611 * let is_type_checked ?(trust=true) uri =
613 * let _ = Cache.find_cooked uri in
617 * trust && trust_obj uri
620 * as the get_cooked_obj but returns a type_checked_obj
623 let is_type_checked ?(trust=true) base_univ uri =
625 let o,u = Cache.find_cooked uri in
626 CheckedObj (o,(CicUniv.merge_ugraphs base_univ u))
628 (* this should return UncheckedObj *)
629 if trust && trust_obj uri then
630 (* trusting means that we will fetch cook it on the fly *)
631 let o,u = add_trusted_uri_to_cache uri in
632 CheckedObj ( o, CicUniv.merge_ugraphs u base_univ )
634 let o,u = find_or_add_to_unchecked uri in
638 (* as the get cooked, but if not present the object is only fetched,
639 * not unfreezed and committed
641 let get_obj base_univ uri =
643 (* the object should be in the cacheOfCookedObjects *)
644 let o,u = Cache.find_cooked uri in
645 o,(CicUniv.merge_ugraphs base_univ u)
647 (* this should be an error case, but if we trust the uri... *)
648 if trust_obj uri then
649 (* trusting we add it to the unchecked list *)
650 let o,u = find_or_add_to_unchecked uri in
651 o,(CicUniv.merge_ugraphs base_univ u)
656 exception OnlyPutOfInductiveDefinitionsIsAllowed
658 let put_inductive_definition uri (obj,ugraph) =
660 Cic.InductiveDefinition _ -> Cache.add_cooked uri (obj,ugraph)
661 | _ -> raise OnlyPutOfInductiveDefinitionsIsAllowed
665 Cache.is_in_cooked uri || Cache.is_in_frozen uri || Cache.is_in_unchecked uri
667 let add_type_checked_term uri (obj,ugraph) =
669 Cic.Constant (s,(Some bo),ty,ul,_) ->
670 Cache.add_cooked ~key:uri (obj,ugraph)
678 ignore (Http_getter.resolve' uri);
680 with Http_getter_types.Key_not_found _ -> false)
682 let remove_term = Cache.remove
685 Cache.list_all_cooked_uris ()
691 let o,ug = get_obj CicUniv.empty_ugraph u in
696 prerr_endline "Who has removed the uri in the meanwhile?";