+exception Object_not_found of UriManager.uri;;
+
+
+(* ************************************************************************** *
+ HERE STARTS THE CACHE MODULE
+ * ************************************************************************** *)
+
+(* I think this should be the right place to implement mecanisms and
+ * invasriants
+ *)
+
+(* Cache that uses == instead of = for testing equality *)
+(* Invariant: an object is always in at most one of the *)
+(* following states: unchecked, frozen and cooked. *)
+module Cache :
+ sig
+ val find_or_add_to_unchecked :
+ UriManager.uri ->
+ get_object_to_add:
+ (UriManager.uri ->
+ Cic.obj * (CicUniv.universe_graph * CicUniv.universe list) option) ->
+ Cic.obj * CicUniv.universe_graph * CicUniv.universe list
+ val can_be_cooked:
+ UriManager.uri -> bool
+ val unchecked_to_frozen :
+ UriManager.uri -> unit
+ val frozen_to_cooked :
+ uri:UriManager.uri -> unit
+ val hack_univ:
+ UriManager.uri -> CicUniv.universe_graph * CicUniv.universe list -> unit
+ val find_cooked :
+ key:UriManager.uri ->
+ Cic.obj * CicUniv.universe_graph * CicUniv.universe list
+ val add_cooked :
+ key:UriManager.uri ->
+ (Cic.obj * CicUniv.universe_graph * CicUniv.universe list) -> unit
+ val remove: UriManager.uri -> unit
+ val dump_to_channel : ?callback:(string -> unit) -> out_channel -> unit
+ val restore_from_channel : ?callback:(string -> unit) -> in_channel -> unit
+ val empty : unit -> unit
+ val is_in_frozen: UriManager.uri -> bool
+ val is_in_unchecked: UriManager.uri -> bool
+ val is_in_cooked: UriManager.uri -> bool
+ val list_all_cooked_uris: unit -> UriManager.uri list
+ end
+=
+ struct
+ (*************************************************************************
+ TASSI: invariant
+ The cacheOfCookedObjects will contain only objects with a valid universe
+ graph. valid means that not None (used if there is no universe file
+ in the universe generation phase).
+ **************************************************************************)
+
+ (* DATA: the data structure that implements the CACHE *)
+ module HashedType =
+ struct
+ type t = UriManager.uri
+ let equal = UriManager.eq
+ let hash = Hashtbl.hash
+ end
+ ;;
+
+ module HT = Hashtbl.Make(HashedType);;
+
+ let cacheOfCookedObjects = HT.create 1009;;
+
+ (* DATA: The parking lists
+ * the lists elements are (uri * (obj * universe_graph option))
+ * ( u, ( o, None )) means that the object has no universes file, this
+ * should happen only in the universe generation phase.
+ * FIXME: if the universe generation is integrated in the library
+ * exportation phase, the 'option' MUST be removed.
+ * ( u, ( o, Some g)) means that the object has a universes file,
+ * the usual case.
+ *)
+
+ (* frozen is used to detect circular dependency. *)
+ let frozen_list = ref [];;
+ (* unchecked is used to store objects just fetched, nothing more. *)
+ let unchecked_list = ref [];;
+
+ let empty () =
+ HT.clear cacheOfCookedObjects;
+ unchecked_list := [] ;
+ frozen_list := []
+ ;;
+
+ (* FIX: universe stuff?? *)
+ let dump_to_channel ?(callback = ignore) oc =
+ HT.iter (fun uri _ -> callback (UriManager.string_of_uri uri))
+ cacheOfCookedObjects;
+ Marshal.to_channel oc cacheOfCookedObjects []
+ ;;
+
+ (* FIX: universes stuff?? *)
+ let restore_from_channel ?(callback = ignore) ic =
+ let restored = Marshal.from_channel ic in
+ (* FIXME: should this empty clean the frozen and unchecked?
+ * if not, the only-one-empty-end-not-3 patch is wrong
+ *)
+ empty ();
+ HT.iter
+ (fun k (v,u,l) ->
+ callback (UriManager.string_of_uri k);
+ let reconsed_entry =
+ CicUtil.rehash_obj v,
+ CicUniv.recons_graph u,
+ List.map CicUniv.recons_univ l
+ in
+ HT.add cacheOfCookedObjects
+ (UriManager.uri_of_string (UriManager.string_of_uri k))
+ reconsed_entry)
+ restored
+ ;;
+
+
+ let is_in_frozen uri =
+ List.mem_assoc uri !frozen_list
+ ;;
+
+ let is_in_unchecked uri =
+ List.mem_assoc uri !unchecked_list
+ ;;
+
+ let is_in_cooked uri =
+ HT.mem cacheOfCookedObjects uri
+ ;;
+
+
+ (*******************************************************************
+ TASSI: invariant
+ we need, in the universe generation phase, to traverse objects
+ that are not yet committed, so we search them in the frozen list.
+ Only uncommitted objects without a universe file (see the assertion)
+ can be searched with method
+ *******************************************************************)
+
+ let find_or_add_to_unchecked uri ~get_object_to_add =
+ try
+ let o,g_and_l = List.assq uri !unchecked_list in
+ match g_and_l with
+ (* FIXME: we accept both cases, as at the end of this function
+ * maybe the None universe outside the cache module should be
+ * avoided elsewhere.
+ *
+ * another thing that should be removed if univ generation phase
+ * and lib exportation are unified.
+ *)
+ | None -> o,CicUniv.empty_ugraph,[]
+ | Some (g,l) -> o,g,l
+ with
+ Not_found ->
+ if List.mem_assq uri !frozen_list then
+ (* CIRCULAR DEPENDENCY DETECTED, print the error and raise *)
+ begin
+ print_endline "\nCircularDependency!\nfrozen list: \n";
+ List.iter (
+ fun (u,(_,o)) ->
+ let su = UriManager.string_of_uri u in
+ let univ = if o = None then "NO_UNIV" else "" in
+ print_endline (su^" "^univ))
+ !frozen_list;
+ raise (CircularDependency (lazy (UriManager.string_of_uri uri)))
+ end
+ else
+ if HT.mem cacheOfCookedObjects uri then
+ (* DOUBLE COOK DETECTED, raise the exception *)
+ raise (AlreadyCooked (UriManager.string_of_uri uri))
+ else
+ (* OK, it is not already frozen nor cooked *)
+ let obj,ugraph_and_univlist = get_object_to_add uri in
+ let ugraph_real, univlist_real =
+ match ugraph_and_univlist with
+ (* FIXME: not sure it is OK*)
+ None -> CicUniv.empty_ugraph, []
+ | Some ((g,l) as g_and_l) -> g_and_l
+ in
+ unchecked_list :=
+ (uri,(obj,ugraph_and_univlist))::!unchecked_list ;
+ obj, ugraph_real, univlist_real
+ ;;
+
+ let unchecked_to_frozen uri =
+ try
+ let obj,ugraph_and_univlist = List.assq uri !unchecked_list in
+ unchecked_list := List.remove_assq uri !unchecked_list ;
+ frozen_list := (uri,(obj,ugraph_and_univlist))::!frozen_list
+ with
+ Not_found -> raise (CouldNotFreeze (UriManager.string_of_uri uri))
+ ;;
+
+
+ (************************************************************
+ TASSI: invariant
+ only object with a valid universe graph can be committed
+
+ this should disappear if the universe generation phase and the
+ library exportation are unified.
+ *************************************************************)
+ let frozen_to_cooked ~uri =
+ try
+ let obj,ugraph_and_univlist = List.assq uri !frozen_list in
+ match ugraph_and_univlist with
+ | None -> assert false (* only NON dummy universes can be committed *)
+ | Some (g,l) ->
+ CicUniv.assert_univs_have_uri g l;
+ frozen_list := List.remove_assq uri !frozen_list ;
+ HT.add cacheOfCookedObjects uri (obj,g,l)
+ with
+ Not_found -> raise (CouldNotUnfreeze (UriManager.string_of_uri uri))
+ ;;
+
+ let can_be_cooked uri =
+ try
+ let obj,ugraph_and_univlist = List.assq uri !frozen_list in
+ (* FIXME: another thing to remove if univ generation phase and lib
+ * exportation are unified.
+ *)
+ match ugraph_and_univlist with
+ None -> false
+ | Some _ -> true
+ with
+ Not_found -> false
+ ;;
+
+ (* this function injects a real universe graph in a (uri, (obj, None))
+ * element of the frozen list.
+ *
+ * FIXME: another thing to remove if univ generation phase and lib
+ * exportation are unified.
+ *)
+ let hack_univ uri (real_ugraph, real_univlist) =
+ try
+ let o,ugraph_and_univlist = List.assq uri !frozen_list in
+ match ugraph_and_univlist with
+ None ->
+ frozen_list := List.remove_assoc uri !frozen_list;
+ frozen_list :=
+ (uri,(o,Some (real_ugraph, real_univlist)))::!frozen_list;
+ | Some g ->
+ debug_print (lazy (
+ "You are probably hacking an object already hacked or an"^
+ " object that has the universe file but is not"^
+ " yet committed."));
+ assert false
+ with
+ Not_found ->
+ debug_print (lazy (
+ "You are hacking an object that is not in the"^
+ " frozen_list, this means you are probably generating an"^
+ " universe file for an object that already"^
+ " as an universe file"));
+ assert false
+ ;;
+
+ let find_cooked ~key:uri = HT.find cacheOfCookedObjects uri ;;
+
+ let add_cooked ~key:uri (obj,ugraph,univlist) =
+ HT.add cacheOfCookedObjects uri (obj,ugraph,univlist)
+ ;;
+
+ (* invariant
+ *
+ * an object can be romeved from the cache only if we are not typechecking
+ * something. this means check and frozen must be empty.
+ *)
+ let remove uri =
+ if !frozen_list <> [] then
+ failwith "CicEnvironment.remove while type checking"
+ else
+ begin
+ HT.remove cacheOfCookedObjects uri;
+ unchecked_list :=
+ List.filter (fun (uri',_) -> not (UriManager.eq uri uri')) !unchecked_list
+ end
+ ;;
+
+ let list_all_cooked_uris () =
+ HT.fold (fun u _ l -> u::l) cacheOfCookedObjects []
+ ;;
+
+ end