aboutsummaryrefslogtreecommitdiffhomepage
path: root/library
diff options
context:
space:
mode:
Diffstat (limited to 'library')
-rw-r--r--library/summary.ml201
-rw-r--r--library/summary.mli39
2 files changed, 122 insertions, 118 deletions
diff --git a/library/summary.ml b/library/summary.ml
index 9f49d1f83..5fe3160e1 100644
--- a/library/summary.ml
+++ b/library/summary.ml
@@ -13,17 +13,22 @@ open Util
module Dyn = Dyn.Make ()
type marshallable = [ `Yes | `No | `Shallow ]
+
type 'a summary_declaration = {
freeze_function : marshallable -> 'a;
unfreeze_function : 'a -> unit;
init_function : unit -> unit }
-let summaries = ref Int.Map.empty
+let sum_mod = ref None
+let sum_map = ref String.Map.empty
let mangle id = id ^ "-SUMMARY"
+let unmangle id = String.(sub id 0 (length id - 8))
+
+let ml_modules = "ML-MODULES"
-let internal_declare_summary hash sumname sdecl =
- let (infun, outfun) = Dyn.Easy.make_dyn (mangle sumname) in
+let internal_declare_summary fadd sumname sdecl =
+ let infun, outfun, tag = Dyn.Easy.make_dyn_tag (mangle sumname) in
let dyn_freeze b = infun (sdecl.freeze_function b)
and dyn_unfreeze sum = sdecl.unfreeze_function (outfun sum)
and dyn_init = sdecl.init_function in
@@ -32,140 +37,114 @@ let internal_declare_summary hash sumname sdecl =
unfreeze_function = dyn_unfreeze;
init_function = dyn_init }
in
- summaries := Int.Map.add hash (sumname, ddecl) !summaries
+ fadd sumname ddecl;
+ tag
-let all_declared_summaries = ref Int.Set.empty
+let declare_ml_modules_summary decl =
+ let ml_add _ ddecl = sum_mod := Some ddecl in
+ internal_declare_summary ml_add ml_modules decl
-let summary_names = ref []
-let name_of_summary name =
- try List.assoc name !summary_names
- with Not_found -> "summary name not found"
+let declare_ml_modules_summary decl =
+ ignore(declare_ml_modules_summary decl)
-let declare_summary sumname decl =
- let hash = String.hash sumname in
- let () = if Int.Map.mem hash !summaries then
- let (name, _) = Int.Map.find hash !summaries in
- anomaly ~label:"Summary.declare_summary"
- (str "Colliding summary names: " ++ str sumname ++ str " vs. " ++ str name ++ str ".")
+let declare_summary_tag sumname decl =
+ let fadd name ddecl = sum_map := String.Map.add name ddecl !sum_map in
+ let () = if String.Map.mem sumname !sum_map then
+ anomaly ~label:"Summary.declare_summary"
+ (str "Colliding summary names: " ++ str sumname ++ str " vs. " ++ str sumname ++ str ".")
in
- all_declared_summaries := Int.Set.add hash !all_declared_summaries;
- summary_names := (hash, sumname) :: !summary_names;
- internal_declare_summary hash sumname decl
+ internal_declare_summary fadd sumname decl
+
+let declare_summary sumname decl =
+ ignore(declare_summary_tag sumname decl)
type frozen = {
- summaries : (int * Dyn.t) list;
+ summaries : Dyn.t String.Map.t;
(** Ordered list w.r.t. the first component. *)
ml_module : Dyn.t option;
(** Special handling of the ml_module summary. *)
}
-let empty_frozen = { summaries = []; ml_module = None; }
-
-let ml_modules = "ML-MODULES"
-let ml_modules_summary = String.hash ml_modules
+let empty_frozen = { summaries = String.Map.empty; ml_module = None }
let freeze_summaries ~marshallable : frozen =
- let fold id (_, decl) accu =
- (* to debug missing Lazy.force
- if marshallable <> `No then begin
- let id, _ = Int.Map.find id !summaries in
- prerr_endline ("begin marshalling " ^ id);
- ignore(Marshal.to_string (decl.freeze_function marshallable) []);
- prerr_endline ("end marshalling " ^ id);
- end;
- /debug *)
- let state = decl.freeze_function marshallable in
- if Int.equal id ml_modules_summary then { accu with ml_module = Some state }
- else { accu with summaries = (id, state) :: accu.summaries }
+ let smap decl = decl.freeze_function marshallable in
+ { summaries = String.Map.map smap !sum_map;
+ ml_module = Option.map (fun decl -> decl.freeze_function marshallable) !sum_mod;
+ }
+
+let unfreeze_single name state =
+ let decl =
+ try String.Map.find name !sum_map
+ with
+ | Not_found ->
+ CErrors.anomaly Pp.(str "trying to unfreeze unregistered summary " ++ str name)
in
- Int.Map.fold_right fold !summaries empty_frozen
-
-let unfreeze_summaries fs =
+ try decl.unfreeze_function state
+ with e when CErrors.noncritical e ->
+ let e = CErrors.push e in
+ Feedback.msg_warning
+ Pp.(seq [str "Error unfreezing summary "; str name; fnl (); CErrors.iprint e]);
+ iraise e
+
+let unfreeze_summaries { summaries; ml_module } =
(* The unfreezing of [ml_modules_summary] has to be anticipated since it
- * may modify the content of [summaries] ny loading new ML modules *)
- let (_, decl) =
- try Int.Map.find ml_modules_summary !summaries
- with Not_found -> anomaly (str "Undeclared summary " ++ str ml_modules ++ str ".")
- in
- let () = match fs.ml_module with
+ * may modify the content of [summaries] by loading new ML modules *)
+ begin match !sum_mod with
| None -> anomaly (str "Undeclared summary " ++ str ml_modules ++ str ".")
- | Some state -> decl.unfreeze_function state
- in
- let fold id (_, decl) states =
- if Int.equal id ml_modules_summary then states
- else match states with
- | [] ->
- let () = decl.init_function () in
- []
- | (nid, state) :: rstates ->
- if Int.equal id nid then
- let () = decl.unfreeze_function state in rstates
- else
- let () = decl.init_function () in states
+ | Some decl -> Option.iter (fun state -> decl.unfreeze_function state) ml_module
+ end;
+ (** We must be independent on the order of the map! *)
+ let ufz name decl =
+ try decl.unfreeze_function String.Map.(find name summaries)
+ with Not_found ->
+ Feedback.msg_warning Pp.(str "Summary was captured out of module scope for entry " ++ str name);
+ decl.init_function ()
in
- let fold id decl state =
- try fold id decl state
- with e when CErrors.noncritical e ->
- let e = CErrors.push e in
- Feedback.msg_error
- Pp.(seq [str "Error unfreezing summary %s\n%s\n%!";
- str (name_of_summary id);
- CErrors.iprint e]);
- iraise e
- in
- (** We rely on the order of the frozen list, and the order of folding *)
- ignore (Int.Map.fold_left fold !summaries fs.summaries)
+ (* String.Map.iter unfreeze_single !sum_map *)
+ String.Map.iter ufz !sum_map
let init_summaries () =
- Int.Map.iter (fun _ (_, decl) -> decl.init_function ()) !summaries
+ String.Map.iter (fun _ decl -> decl.init_function ()) !sum_map
(** For global tables registered statically before the end of coqtop
launch, the following empty [init_function] could be used. *)
let nop () = ()
-(** Selective freeze *)
+(** Summary projection *)
+let project_from_summary { summaries } tag =
+ let id = unmangle (Dyn.repr tag) in
+ let state = String.Map.find id summaries in
+ Option.get (Dyn.Easy.prj state tag)
+
+let modify_summary st tag v =
+ let id = unmangle (Dyn.repr tag) in
+ let summaries = String.Map.set id (Dyn.Easy.inj v tag) st.summaries in
+ {st with summaries}
-type frozen_bits = (int * Dyn.t) list
+let remove_from_summary st tag =
+ let id = unmangle (Dyn.repr tag) in
+ let summaries = String.Map.remove id st.summaries in
+ {st with summaries}
+
+(** Selective freeze *)
-let ids_of_string_list complement ids =
- if not complement then List.map String.hash ids
- else
- let fold accu id =
- let id = String.hash id in
- Int.Set.remove id accu
- in
- let ids = List.fold_left fold !all_declared_summaries ids in
- Int.Set.elements ids
+type frozen_bits = Dyn.t String.Map.t
let freeze_summary ~marshallable ?(complement=false) ids =
- let ids = ids_of_string_list complement ids in
- List.map (fun id ->
- let (_, summary) = Int.Map.find id !summaries in
- id, summary.freeze_function marshallable)
- ids
-
-let unfreeze_summary datas =
- List.iter
- (fun (id, data) ->
- let (name, summary) = Int.Map.find id !summaries in
- try summary.unfreeze_function data
- with e ->
- let e = CErrors.push e in
- prerr_endline ("Exception unfreezing " ^ name);
- iraise e)
- datas
+ let sub_map = String.Map.filter (fun id _ -> complement <> List.(mem id ids)) !sum_map in
+ String.Map.map (fun decl -> decl.freeze_function marshallable) sub_map
+
+let unfreeze_summary = String.Map.iter unfreeze_single
let surgery_summary { summaries; ml_module } bits =
- let summaries = List.map (fun (id, _ as orig) ->
- try id, List.assoc id bits
- with Not_found -> orig)
- summaries in
+ let summaries =
+ String.Map.fold (fun hash state sum -> String.Map.set hash state sum ) summaries bits in
{ summaries; ml_module }
let project_summary { summaries; ml_module } ?(complement=false) ids =
- let ids = ids_of_string_list complement ids in
- List.filter (fun (id, _) -> List.mem id ids) summaries
+ String.Map.filter (fun name _ -> complement <> List.(mem name ids)) summaries
let pointer_equal l1 l2 =
let ptr_equal d1 d2 =
@@ -174,19 +153,22 @@ let pointer_equal l1 l2 =
match Dyn.eq t1 t2 with
| None -> false
| Some Refl -> x1 == x2
- in
+ in
+ let l1, l2 = String.Map.bindings l1, String.Map.bindings l2 in
CList.for_all2eq
(fun (id1,v1) (id2,v2) -> id1 = id2 && ptr_equal v1 v2) l1 l2
(** All-in-one reference declaration + registration *)
-let ref ?(freeze=fun _ r -> r) ~name x =
+let ref_tag ?(freeze=fun _ r -> r) ~name x =
let r = ref x in
- declare_summary name
+ let tag = declare_summary_tag name
{ freeze_function = (fun b -> freeze b !r);
unfreeze_function = ((:=) r);
- init_function = (fun () -> r := x) };
- r
+ init_function = (fun () -> r := x) } in
+ r, tag
+
+let ref ?freeze ~name x = fst @@ ref_tag ?freeze ~name x
module Local = struct
@@ -198,8 +180,7 @@ let (!) r =
let key, name = !r in
try CEphemeron.get key
with CEphemeron.InvalidKey ->
- let _, { init_function } =
- Int.Map.find (String.hash (mangle name)) !summaries in
+ let { init_function } = String.Map.find name !sum_map in
init_function ();
CEphemeron.get (fst !r)
diff --git a/library/summary.mli b/library/summary.mli
index d093d95f2..9fc6df6ad 100644
--- a/library/summary.mli
+++ b/library/summary.mli
@@ -36,6 +36,12 @@ type 'a summary_declaration = {
val declare_summary : string -> 'a summary_declaration -> unit
+(** We provide safe projection from the summary to the types stored in
+ it.*)
+module Dyn : Dyn.S
+
+val declare_summary_tag : string -> 'a summary_declaration -> 'a Dyn.tag
+
(** All-in-one reference declaration + summary registration.
It behaves just as OCaml's standard [ref] function, except
that a [declare_summary] is done, with [name] as string.
@@ -43,6 +49,7 @@ val declare_summary : string -> 'a summary_declaration -> unit
The [freeze_function] can be overridden *)
val ref : ?freeze:(marshallable -> 'a -> 'a) -> name:string -> 'a -> 'a ref
+val ref_tag : ?freeze:(marshallable -> 'a -> 'a) -> name:string -> 'a -> 'a ref * 'a Dyn.tag
(* As [ref] but the value is local to a process, i.e. not sent to, say, proof
* workers. It is useful to implement a local cache for example. *)
@@ -55,10 +62,11 @@ module Local : sig
end
-(** Special name for the summary of ML modules. This summary entry is
- special because its unfreeze may load ML code and hence add summary
- entries. Thus is has to be recognizable, and handled appropriately *)
-val ml_modules : string
+(** Special summary for ML modules. This summary entry is special
+ because its unfreeze may load ML code and hence add summary
+ entries. Thus is has to be recognizable, and handled properly.
+ *)
+val declare_ml_modules_summary : 'a summary_declaration -> unit
(** For global tables registered statically before the end of coqtop
launch, the following empty [init_function] could be used. *)
@@ -75,16 +83,31 @@ val freeze_summaries : marshallable:marshallable -> frozen
val unfreeze_summaries : frozen -> unit
val init_summaries : unit -> unit
-(** The type [frozen_bits] is a snapshot of some of the registered tables *)
+(** Typed projection of the summary. Experimental API, use with CARE *)
+
+val modify_summary : frozen -> 'a Dyn.tag -> 'a -> frozen
+val project_from_summary : frozen -> 'a Dyn.tag -> 'a
+val remove_from_summary : frozen -> 'a Dyn.tag -> frozen
+
+(** The type [frozen_bits] is a snapshot of some of the registered
+ tables. It is DEPRECATED in favor of the typed projection
+ version. *)
+
type frozen_bits
+[@@ocaml.deprecated "Please use the typed version of summary projection"]
-val freeze_summary :
- marshallable:marshallable -> ?complement:bool -> string list -> frozen_bits
+[@@@ocaml.warning "-3"]
+val freeze_summary : marshallable:marshallable -> ?complement:bool -> string list -> frozen_bits
+[@@ocaml.deprecated "Please use the typed version of summary projection"]
val unfreeze_summary : frozen_bits -> unit
+[@@ocaml.deprecated "Please use the typed version of summary projection"]
val surgery_summary : frozen -> frozen_bits -> frozen
+[@@ocaml.deprecated "Please use the typed version of summary projection"]
val project_summary : frozen -> ?complement:bool -> string list -> frozen_bits
+[@@ocaml.deprecated "Please use the typed version of summary projection"]
val pointer_equal : frozen_bits -> frozen_bits -> bool
+[@@ocaml.deprecated "Please use the typed version of summary projection"]
+[@@@ocaml.warning "+3"]
(** {6 Debug} *)
-
val dump : unit -> (int * string) list