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
47 let debug_print = fun x -> prerr_endline (Lazy.force x)
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 :
82 Cic.obj * (CicUniv.universe_graph * CicUniv.universe list) option) ->
83 Cic.obj * CicUniv.universe_graph * CicUniv.universe list
85 UriManager.uri -> bool
86 val unchecked_to_frozen :
87 UriManager.uri -> unit
88 val frozen_to_cooked :
89 uri:UriManager.uri -> unit
91 UriManager.uri -> CicUniv.universe_graph * CicUniv.universe list -> unit
94 Cic.obj * CicUniv.universe_graph * CicUniv.universe list
97 (Cic.obj * CicUniv.universe_graph * CicUniv.universe list) -> unit
98 val remove: UriManager.uri -> unit
99 val dump_to_channel : ?callback:(string -> unit) -> out_channel -> unit
100 val restore_from_channel : ?callback:(string -> unit) -> in_channel -> unit
101 val empty : unit -> unit
102 val is_in_frozen: UriManager.uri -> bool
103 val is_in_unchecked: UriManager.uri -> bool
104 val is_in_cooked: UriManager.uri -> bool
105 val list_all_cooked_uris: unit -> UriManager.uri list
109 (*************************************************************************
111 The cacheOfCookedObjects will contain only objects with a valid universe
112 graph. valid means that not None (used if there is no universe file
113 in the universe generation phase).
114 **************************************************************************)
116 (* DATA: the data structure that implements the CACHE *)
119 type t = UriManager.uri
120 let equal = UriManager.eq
121 let hash = Hashtbl.hash
125 module HT = Hashtbl.Make(HashedType);;
127 let cacheOfCookedObjects = HT.create 1009;;
129 (* DATA: The parking lists
130 * the lists elements are (uri * (obj * universe_graph option))
131 * ( u, ( o, None )) means that the object has no universes file, this
132 * should happen only in the universe generation phase.
133 * FIXME: if the universe generation is integrated in the library
134 * exportation phase, the 'option' MUST be removed.
135 * ( u, ( o, Some g)) means that the object has a universes file,
139 (* frozen is used to detect circular dependency. *)
140 let frozen_list = ref [];;
141 (* unchecked is used to store objects just fetched, nothing more. *)
142 let unchecked_list = ref [];;
144 (* FIXED: should be ok even if not touched *)
145 (* used to hash cons uris on restore to grant URI structure unicity *)
147 let module C = Cic in
149 UriManager.uri_of_string (UriManager.string_of_uri uri)
151 let rec restore_in_term =
153 | (C.Rel _) as t -> t
154 | C.Var (uri,exp_named_subst) ->
155 let uri' = recons uri in
156 let exp_named_subst' =
158 (function (uri,t) ->(recons uri,restore_in_term t))
161 C.Var (uri',exp_named_subst')
167 | Some t -> Some (restore_in_term t)
171 | C.Sort (C.Type u) ->
172 CicUniv.assert_univ u;
173 C.Sort (C.Type (CicUniv.recons_univ u))
175 | C.Implicit _ as t -> t
176 | C.Cast (te,ty) -> C.Cast (restore_in_term te, restore_in_term ty)
177 | C.Prod (n,s,t) -> C.Prod (n, restore_in_term s, restore_in_term t)
178 | C.Lambda (n,s,t) -> C.Lambda (n, restore_in_term s, restore_in_term t)
179 | C.LetIn (n,s,t) -> C.LetIn (n, restore_in_term s, restore_in_term t)
180 | C.Appl l -> C.Appl (List.map restore_in_term l)
181 | C.Const (uri,exp_named_subst) ->
182 let uri' = recons uri in
183 let exp_named_subst' =
185 (function (uri,t) -> (recons uri,restore_in_term t)) exp_named_subst
187 C.Const (uri',exp_named_subst')
188 | C.MutInd (uri,tyno,exp_named_subst) ->
189 let uri' = recons uri in
190 let exp_named_subst' =
192 (function (uri,t) -> (recons uri,restore_in_term t)) exp_named_subst
194 C.MutInd (uri',tyno,exp_named_subst')
195 | C.MutConstruct (uri,tyno,consno,exp_named_subst) ->
196 let uri' = recons uri in
197 let exp_named_subst' =
199 (function (uri,t) -> (recons uri,restore_in_term t)) exp_named_subst
201 C.MutConstruct (uri',tyno,consno,exp_named_subst')
202 | C.MutCase (uri,i,outty,t,pl) ->
203 C.MutCase (recons uri, i, restore_in_term outty, restore_in_term t,
204 List.map restore_in_term pl)
206 let len = List.length fl in
209 (fun (name, i, ty, bo) ->
210 (name, i, restore_in_term ty, restore_in_term bo))
215 let len = List.length fl in
218 (fun (name, ty, bo) -> (name, restore_in_term ty, restore_in_term bo))
221 C.CoFix (i, liftedfl)
224 C.Constant (name,bo,ty,params,attrs) ->
228 | Some bo -> Some (restore_in_term bo)
230 let ty' = restore_in_term ty in
231 let params' = List.map recons params in
232 C.Constant (name, bo', ty', params',attrs)
233 | C.CurrentProof (name,conjs,bo,ty,params,attrs) ->
236 (function (i,hyps,ty) ->
240 | Some (name,C.Decl t) ->
241 Some (name,C.Decl (restore_in_term t))
242 | Some (name,C.Def (bo,ty)) ->
246 | Some ty'' -> Some (restore_in_term ty'')
248 Some (name,C.Def (restore_in_term bo, ty'))) hyps,
252 let bo' = restore_in_term bo in
253 let ty' = restore_in_term ty in
254 let params' = List.map recons params in
255 C.CurrentProof (name, conjs', bo', ty', params',attrs)
256 | C.Variable (name,bo,ty,params,attrs) ->
260 | Some bo -> Some (restore_in_term bo)
262 let ty' = restore_in_term ty in
263 let params' = List.map recons params in
264 C.Variable (name, bo', ty', params',attrs)
265 | C.InductiveDefinition (tl,params,paramsno,attrs) ->
266 let params' = List.map recons params in
268 List.map (function (name, inductive, ty, constructors) ->
273 (function (name, ty) -> name, restore_in_term ty)
277 C.InductiveDefinition (tl', params', paramsno, attrs)
281 HT.clear cacheOfCookedObjects;
282 unchecked_list := [] ;
286 (* FIX: universe stuff?? *)
287 let dump_to_channel ?(callback = ignore) oc =
288 HT.iter (fun uri _ -> callback (UriManager.string_of_uri uri))
289 cacheOfCookedObjects;
290 Marshal.to_channel oc cacheOfCookedObjects []
293 (* FIX: universes stuff?? *)
294 let restore_from_channel ?(callback = ignore) ic =
295 let restored = Marshal.from_channel ic in
296 (* FIXME: should this empty clean the frozen and unchecked?
297 * if not, the only-one-empty-end-not-3 patch is wrong
302 callback (UriManager.string_of_uri k);
304 restore_uris v,CicUniv.recons_graph u,List.map CicUniv.recons_univ l
306 HT.add cacheOfCookedObjects
307 (UriManager.uri_of_string (UriManager.string_of_uri k))
313 let is_in_frozen uri =
314 List.mem_assoc uri !frozen_list
317 let is_in_unchecked uri =
318 List.mem_assoc uri !unchecked_list
321 let is_in_cooked uri =
322 HT.mem cacheOfCookedObjects uri
326 (*******************************************************************
328 we need, in the universe generation phase, to traverse objects
329 that are not yet committed, so we search them in the frozen list.
330 Only uncommitted objects without a universe file (see the assertion)
331 can be searched with method
332 *******************************************************************)
334 let find_or_add_to_unchecked uri ~get_object_to_add =
336 let o,g_and_l = List.assq uri !unchecked_list in
338 (* FIXME: we accept both cases, as at the end of this function
339 * maybe the None universe outside the cache module should be
342 * another thing that should be removed if univ generation phase
343 * and lib exportation are unified.
345 | None -> o,CicUniv.empty_ugraph,[]
346 | Some (g,l) -> o,g,l
349 if List.mem_assq uri !frozen_list then
350 (* CIRCULAR DEPENDENCY DETECTED, print the error and raise *)
352 print_endline "\nCircularDependency!\nfrozen list: \n";
355 let su = UriManager.string_of_uri u in
356 let univ = if o = None then "NO_UNIV" else "" in
357 print_endline (su^" "^univ))
359 raise (CircularDependency (UriManager.string_of_uri uri))
362 if HT.mem cacheOfCookedObjects uri then
363 (* DOUBLE COOK DETECTED, raise the exception *)
364 raise (AlreadyCooked (UriManager.string_of_uri uri))
366 (* OK, it is not already frozen nor cooked *)
367 let obj,ugraph_and_univlist = get_object_to_add uri in
368 let ugraph_real, univlist_real =
369 match ugraph_and_univlist with
370 (* FIXME: not sure it is OK*)
371 None -> CicUniv.empty_ugraph, []
372 | Some ((g,l) as g_and_l) -> g_and_l
375 (uri,(obj,ugraph_and_univlist))::!unchecked_list ;
376 obj, ugraph_real, univlist_real
379 let unchecked_to_frozen uri =
381 let obj,ugraph_and_univlist = List.assq uri !unchecked_list in
382 unchecked_list := List.remove_assq uri !unchecked_list ;
383 frozen_list := (uri,(obj,ugraph_and_univlist))::!frozen_list
385 Not_found -> raise (CouldNotFreeze (UriManager.string_of_uri uri))
389 (************************************************************
391 only object with a valid universe graph can be committed
393 this should disappear if the universe generation phase and the
394 library exportation are unified.
395 *************************************************************)
396 let frozen_to_cooked ~uri =
398 let obj,ugraph_and_univlist = List.assq uri !frozen_list in
399 match ugraph_and_univlist with
400 | None -> assert false (* only NON dummy universes can be committed *)
402 CicUniv.assert_univs_have_uri g l;
403 frozen_list := List.remove_assq uri !frozen_list ;
404 HT.add cacheOfCookedObjects uri (obj,g,l)
406 Not_found -> raise (CouldNotUnfreeze (UriManager.string_of_uri uri))
409 let can_be_cooked uri =
411 let obj,ugraph_and_univlist = List.assq uri !frozen_list in
412 (* FIXME: another thing to remove if univ generation phase and lib
413 * exportation are unified.
415 match ugraph_and_univlist with
422 (* this function injects a real universe graph in a (uri, (obj, None))
423 * element of the frozen list.
425 * FIXME: another thing to remove if univ generation phase and lib
426 * exportation are unified.
428 let hack_univ uri (real_ugraph, real_univlist) =
430 let o,ugraph_and_univlist = List.assq uri !frozen_list in
431 match ugraph_and_univlist with
433 frozen_list := List.remove_assoc uri !frozen_list;
435 (uri,(o,Some (real_ugraph, real_univlist)))::!frozen_list;
438 "You are probably hacking an object already hacked or an"^
439 " object that has the universe file but is not"^
445 "You are hacking an object that is not in the"^
446 " frozen_list, this means you are probably generating an"^
447 " universe file for an object that already"^
448 " as an universe file"));
452 let find_cooked ~key:uri = HT.find cacheOfCookedObjects uri ;;
454 let add_cooked ~key:uri (obj,ugraph,univlist) =
455 HT.add cacheOfCookedObjects uri (obj,ugraph,univlist)
460 * an object can be romeved from the cache only if we are not typechecking
461 * something. this means check and frozen must be empty.
464 if !frozen_list <> [] then
465 failwith "CicEnvironment.remove while type checking"
468 HT.remove cacheOfCookedObjects uri;
470 List.filter (fun (uri',_) -> not (UriManager.eq uri uri')) !unchecked_list
474 let list_all_cooked_uris () =
475 HT.fold (fun u _ l -> u::l) cacheOfCookedObjects []
481 (* ************************************************************************
482 HERE ENDS THE CACHE MODULE
483 * ************************************************************************ *)
485 (* exported cache functions *)
486 let dump_to_channel = Cache.dump_to_channel;;
487 let restore_from_channel = Cache.restore_from_channel;;
488 let empty = Cache.empty;;
490 let total_parsing_time = ref 0.0
492 let get_object_to_add uri =
494 let filename = Http_getter.getxml' uri in
496 match UriManager.bodyuri_of_uri uri with
499 if Http_getter.exists' bodyuri then
500 Some (Http_getter.getxml' bodyuri)
506 let time = Unix.gettimeofday() in
507 let rc = CicParser.obj_of_xml uri filename bodyfilename in
508 total_parsing_time :=
509 !total_parsing_time +. ((Unix.gettimeofday()) -. time );
513 | CicParser.Getter_failure ("key_not_found", uri) ->
514 raise (Object_not_found (UriManager.uri_of_string uri))
517 let ugraph_and_univlist,filename_univ =
520 let univ_uri = UriManager.univgraphuri_of_uri uri in
521 Http_getter.getxml' univ_uri
523 Some (CicUniv.ugraph_and_univlist_of_xml filename_univ),
526 | Http_getter_types.Key_not_found _
527 | Http_getter_types.Unresolvable_URI _ ->
529 "WE HAVE NO UNIVERSE FILE FOR " ^ (UriManager.string_of_uri uri)));
530 (* WE SHOULD FAIL (or return None, None *)
531 Some (CicUniv.empty_ugraph, []), None
533 obj, ugraph_and_univlist
534 with Http_getter_types.Key_not_found _ -> raise (Object_not_found uri)
537 (* this is the function to fetch the object in the unchecked list and
538 * nothing more (except returning it)
540 let find_or_add_to_unchecked uri =
541 Cache.find_or_add_to_unchecked uri ~get_object_to_add
543 (* set_type_checking_info uri *)
544 (* must be called once the type-checking of uri is finished *)
545 (* The object whose uri is uri is unfreezed *)
547 (* the replacement ugraph must be the one returned by the *)
548 (* typechecker, restricted with the CicUnivUtils.clean_and_fill *)
549 let set_type_checking_info ?(replace_ugraph_and_univlist=None) uri =
551 if not (Cache.can_be_cooked uri) && replace_ugraph <> None then begin
553 "?replace_ugraph must be None if you are not committing an "^
554 "object that has a universe graph associated "^
555 "(can happen only in the fase of universes graphs generation)."));
559 match Cache.can_be_cooked uri, replace_ugraph_and_univlist with
563 "?replace_ugraph must be (Some ugraph) when committing an object that "^
564 "has no associated universe graph. If this is in make_univ phase you "^
565 "should drop this exception and let univ_make commit thi object with "^
566 "proper arguments"));
569 (match replace_ugraph_and_univlist with
571 | Some g_and_l -> Cache.hack_univ uri g_and_l);
572 Cache.frozen_to_cooked uri
575 (* fetch, unfreeze and commit an uri to the cacheOfCookedObjects and
576 * return the object,ugraph
578 let add_trusted_uri_to_cache uri =
579 let o,u,_ = find_or_add_to_unchecked uri in
580 Cache.unchecked_to_frozen uri;
581 set_type_checking_info uri;
583 Cache.find_cooked uri
584 with Not_found -> assert false
587 (* get the uri, if we trust it will be added to the cacheOfCookedObjects *)
588 let get_cooked_obj_with_univlist ?(trust=true) base_univ uri =
590 (* the object should be in the cacheOfCookedObjects *)
591 let o,u,l = Cache.find_cooked uri in
592 o,(CicUniv.merge_ugraphs base_univ u),l
594 (* this should be an error case, but if we trust the uri... *)
595 if trust && trust_obj uri then
596 (* trusting means that we will fetch cook it on the fly *)
597 let o,u,l = add_trusted_uri_to_cache uri in
598 o,(CicUniv.merge_ugraphs base_univ u),l
600 (* we don't trust the uri, so we fail *)
602 debug_print (lazy ("CACHE MISS: " ^ (UriManager.string_of_uri uri)));
606 let get_cooked_obj ?trust base_univ uri =
607 let o,g,_ = get_cooked_obj_with_univlist ?trust base_univ uri in
610 (* This has not the old semantic :( but is what the name suggests
612 * let is_type_checked ?(trust=true) uri =
614 * let _ = Cache.find_cooked uri in
618 * trust && trust_obj uri
621 * as the get_cooked_obj but returns a type_checked_obj
624 let is_type_checked ?(trust=true) base_univ uri =
626 let o,u,_ = Cache.find_cooked uri in
627 CheckedObj (o,(CicUniv.merge_ugraphs base_univ u))
629 (* this should return UncheckedObj *)
630 if trust && trust_obj uri then
631 (* trusting means that we will fetch cook it on the fly *)
632 let o,u,_ = add_trusted_uri_to_cache uri in
633 CheckedObj ( o, CicUniv.merge_ugraphs u base_univ )
635 let o,u,_ = find_or_add_to_unchecked uri in
636 Cache.unchecked_to_frozen uri;
640 (* as the get cooked, but if not present the object is only fetched,
641 * not unfreezed and committed
643 let get_obj base_univ uri =
645 (* the object should be in the cacheOfCookedObjects *)
646 let o,u,_ = Cache.find_cooked uri in
647 o,(CicUniv.merge_ugraphs base_univ u)
649 (* this should be an error case, but if we trust the uri... *)
650 let o,u,_ = find_or_add_to_unchecked uri in
651 o,(CicUniv.merge_ugraphs base_univ u)
655 Cache.is_in_cooked uri || Cache.is_in_frozen uri || Cache.is_in_unchecked uri
657 let add_type_checked_obj uri (obj,ugraph,univlist) =
658 Cache.add_cooked ~key:uri (obj,ugraph,univlist)
660 let in_library uri = in_cache uri || Http_getter.exists' uri
662 let remove_obj = Cache.remove
665 Cache.list_all_cooked_uris ()
671 let o,ug = get_obj CicUniv.empty_ugraph u in
676 debug_print (lazy "Who has removed the uri in the meanwhile?");