aboutsummaryrefslogtreecommitdiff
path: root/kernel
diff options
context:
space:
mode:
Diffstat (limited to 'kernel')
-rw-r--r--kernel/environ.ml20
-rw-r--r--kernel/safe_typing.ml4
-rw-r--r--kernel/uGraph.ml16
-rw-r--r--kernel/uGraph.mli2
4 files changed, 32 insertions, 10 deletions
diff --git a/kernel/environ.ml b/kernel/environ.ml
index f61dd0c101..019c0a6819 100644
--- a/kernel/environ.ml
+++ b/kernel/environ.ml
@@ -384,8 +384,26 @@ let set_engagement c env = (* Unsafe *)
{ env with env_stratification =
{ env.env_stratification with env_engagement = c } }
+(* It's convenient to use [{flags with foo = bar}] so we're smart wrt to it. *)
+let same_flags {
+ check_guarded;
+ check_universes;
+ conv_oracle;
+ share_reduction;
+ enable_VM;
+ enable_native_compiler;
+ } alt =
+ check_guarded == alt.check_guarded &&
+ check_universes == alt.check_universes &&
+ conv_oracle == alt.conv_oracle &&
+ share_reduction == alt.share_reduction &&
+ enable_VM == alt.enable_VM &&
+ enable_native_compiler == alt.enable_native_compiler
+[@warning "+9"]
+
let set_typing_flags c env = (* Unsafe *)
- { env with env_typing_flags = c }
+ if same_flags env.env_typing_flags c then env
+ else { env with env_typing_flags = c }
(* Global constants *)
diff --git a/kernel/safe_typing.ml b/kernel/safe_typing.ml
index df10398b2f..2464df799e 100644
--- a/kernel/safe_typing.ml
+++ b/kernel/safe_typing.ml
@@ -192,7 +192,9 @@ let set_engagement c senv =
engagement = Some c }
let set_typing_flags c senv =
- { senv with env = Environ.set_typing_flags c senv.env }
+ let env = Environ.set_typing_flags c senv.env in
+ if env == senv.env then senv
+ else { senv with env }
let set_share_reduction b senv =
let flags = Environ.typing_flags senv.env in
diff --git a/kernel/uGraph.ml b/kernel/uGraph.ml
index 9ff51fca55..9083156745 100644
--- a/kernel/uGraph.ml
+++ b/kernel/uGraph.ml
@@ -942,34 +942,36 @@ let check_eq_instances g t1 t2 =
(** Pretty-printing *)
+let pr_umap sep pr map =
+ let cmp (u,_) (v,_) = Level.compare u v in
+ Pp.prlist_with_sep sep pr (List.sort cmp (UMap.bindings map))
+
let pr_arc prl = function
| _, Canonical {univ=u; ltle; _} ->
if UMap.is_empty ltle then mt ()
else
prl u ++ str " " ++
v 0
- (pr_sequence (fun (v, strict) ->
+ (pr_umap Pp.spc (fun (v, strict) ->
(if strict then str "< " else str "<= ") ++ prl v)
- (UMap.bindings ltle)) ++
+ ltle) ++
fnl ()
| u, Equiv v ->
prl u ++ str " = " ++ prl v ++ fnl ()
let pr_universes prl g =
- let graph = UMap.fold (fun u a l -> (u,a)::l) g.entries [] in
- prlist (pr_arc prl) graph
+ pr_umap mt (pr_arc prl) g.entries
(* Dumping constraints to a file *)
let dump_universes output g =
let dump_arc u = function
| Canonical {univ=u; ltle; _} ->
- let u_str = Level.to_string u in
UMap.iter (fun v strict ->
let typ = if strict then Lt else Le in
- output typ u_str (Level.to_string v)) ltle;
+ output typ u v) ltle;
| Equiv v ->
- output Eq (Level.to_string u) (Level.to_string v)
+ output Eq u v
in
UMap.iter dump_arc g.entries
diff --git a/kernel/uGraph.mli b/kernel/uGraph.mli
index 4336a22b8c..a2cc5b3116 100644
--- a/kernel/uGraph.mli
+++ b/kernel/uGraph.mli
@@ -86,7 +86,7 @@ val check_subtype : AUContext.t check_function
(** {6 Dumping to a file } *)
val dump_universes :
- (constraint_type -> string -> string -> unit) -> t -> unit
+ (constraint_type -> Level.t -> Level.t -> unit) -> t -> unit
(** {6 Debugging} *)
val check_universes_invariants : t -> unit