aboutsummaryrefslogtreecommitdiff
path: root/kernel
diff options
context:
space:
mode:
Diffstat (limited to 'kernel')
-rw-r--r--kernel/declarations.ml20
-rw-r--r--kernel/declareops.ml18
-rw-r--r--kernel/declareops.mli1
-rw-r--r--kernel/mod_typing.ml11
-rw-r--r--kernel/modops.ml48
-rw-r--r--kernel/nativeconv.ml2
-rw-r--r--kernel/nativelib.ml32
-rw-r--r--kernel/nativelib.mli2
-rw-r--r--kernel/pre_env.ml2
-rw-r--r--kernel/safe_typing.ml10
-rw-r--r--kernel/subtyping.ml2
-rw-r--r--kernel/univ.ml265
12 files changed, 155 insertions, 258 deletions
diff --git a/kernel/declarations.ml b/kernel/declarations.ml
index 9697b0b8b2..e17fb1c38f 100644
--- a/kernel/declarations.ml
+++ b/kernel/declarations.ml
@@ -250,16 +250,16 @@ and module_implementation =
| Struct of module_signature (** interactive body *)
| FullStruct (** special case of [Struct] : the body is exactly [mod_type] *)
-and module_body =
+and 'a generic_module_body =
{ mod_mp : module_path; (** absolute path of the module *)
- mod_expr : module_implementation; (** implementation *)
+ mod_expr : 'a; (** implementation *)
mod_type : module_signature; (** expanded type *)
mod_type_alg : module_expression option; (** algebraic type *)
mod_constraints : Univ.ContextSet.t; (**
set of all universes constraints in the module *)
mod_delta : Mod_subst.delta_resolver; (**
quotiented set of equivalent constants and inductive names *)
- mod_retroknowledge : Retroknowledge.action list }
+ mod_retroknowledge : 'a module_retroknowledge }
(** For a module, there are five possible situations:
- [Declare Module M : T] then [mod_expr = Abstract; mod_type_alg = Some T]
@@ -269,13 +269,19 @@ and module_body =
- [Module M : T. ... End M] then [mod_expr = Struct; mod_type_alg = Some T]
And of course, all these situations may be functors or not. *)
-(** A [module_type_body] is just a [module_body] with no
- implementation ([mod_expr] always [Abstract]) and also
- an empty [mod_retroknowledge]. Its [mod_type_alg] contains
+and module_body = module_implementation generic_module_body
+
+(** A [module_type_body] is just a [module_body] with no implementation and
+ also an empty [mod_retroknowledge]. Its [mod_type_alg] contains
the algebraic definition of this module type, or [None]
if it has been built interactively. *)
-and module_type_body = module_body
+and module_type_body = unit generic_module_body
+
+and _ module_retroknowledge =
+| ModBodyRK :
+ Retroknowledge.action list -> module_implementation module_retroknowledge
+| ModTypeRK : unit module_retroknowledge
(** Extra invariants :
diff --git a/kernel/declareops.ml b/kernel/declareops.ml
index 85dd1e66db..66d66c7d09 100644
--- a/kernel/declareops.ml
+++ b/kernel/declareops.ml
@@ -318,7 +318,7 @@ let rec hcons_structure_field_body sb = match sb with
let mb' = hcons_module_body mb in
if mb == mb' then sb else SFBmodule mb'
| SFBmodtype mb ->
- let mb' = hcons_module_body mb in
+ let mb' = hcons_module_type mb in
if mb == mb' then sb else SFBmodtype mb'
and hcons_structure_body sb =
@@ -331,10 +331,10 @@ and hcons_structure_body sb =
List.smartmap map sb
and hcons_module_signature ms =
- hcons_functorize hcons_module_body hcons_structure_body hcons_module_signature ms
+ hcons_functorize hcons_module_type hcons_structure_body hcons_module_signature ms
and hcons_module_expression me =
- hcons_functorize hcons_module_body hcons_module_alg_expr hcons_module_expression me
+ hcons_functorize hcons_module_type hcons_module_alg_expr hcons_module_expression me
and hcons_module_implementation mip = match mip with
| Abstract -> Abstract
@@ -346,9 +346,11 @@ and hcons_module_implementation mip = match mip with
if ms == ms' then mip else Struct ms
| FullStruct -> FullStruct
-and hcons_module_body mb =
+and hcons_generic_module_body :
+ 'a. ('a -> 'a) -> 'a generic_module_body -> 'a generic_module_body =
+ fun hcons_impl mb ->
let mp' = mb.mod_mp in
- let expr' = hcons_module_implementation mb.mod_expr in
+ let expr' = hcons_impl mb.mod_expr in
let type' = hcons_module_signature mb.mod_type in
let type_alg' = mb.mod_type_alg in
let constraints' = Univ.hcons_universe_context_set mb.mod_constraints in
@@ -373,3 +375,9 @@ and hcons_module_body mb =
mod_delta = delta';
mod_retroknowledge = retroknowledge';
}
+
+and hcons_module_body mb =
+ hcons_generic_module_body hcons_module_implementation mb
+
+and hcons_module_type mb =
+ hcons_generic_module_body (fun () -> ()) mb
diff --git a/kernel/declareops.mli b/kernel/declareops.mli
index a8ba5fa392..b2d29759da 100644
--- a/kernel/declareops.mli
+++ b/kernel/declareops.mli
@@ -78,3 +78,4 @@ val safe_flags : typing_flags
val hcons_const_body : constant_body -> constant_body
val hcons_mind : mutual_inductive_body -> mutual_inductive_body
val hcons_module_body : module_body -> module_body
+val hcons_module_type : module_type_body -> module_type_body
diff --git a/kernel/mod_typing.ml b/kernel/mod_typing.ml
index 0888ccc109..d2b41aae98 100644
--- a/kernel/mod_typing.ml
+++ b/kernel/mod_typing.ml
@@ -264,7 +264,9 @@ let rec translate_mse env mpo inl = function
|MEident mp1 as me ->
let mb = match mpo with
|Some mp -> strengthen_and_subst_mb (lookup_module mp1 env) mp false
- |None -> lookup_modtype mp1 env
+ |None ->
+ let mt = lookup_modtype mp1 env in
+ module_body_of_type mt.mod_mp mt
in
mb.mod_type, me, mb.mod_delta, Univ.ContextSet.empty
|MEapply (fe,mp1) ->
@@ -281,9 +283,11 @@ let mk_mod mp e ty cst reso =
mod_type_alg = None;
mod_constraints = cst;
mod_delta = reso;
- mod_retroknowledge = [] }
+ mod_retroknowledge = ModBodyRK []; }
-let mk_modtype mp ty cst reso = mk_mod mp Abstract ty cst reso
+let mk_modtype mp ty cst reso =
+ let mb = mk_mod mp Abstract ty cst reso in
+ { mb with mod_expr = (); mod_retroknowledge = ModTypeRK }
let rec translate_mse_funct env mpo inl mse = function
|[] ->
@@ -319,6 +323,7 @@ let finalize_module env mp (sign,alg,reso,cst) restype = match restype with
{ res_mtb with
mod_mp = mp;
mod_expr = impl;
+ mod_retroknowledge = ModBodyRK [];
(** cst from module body typing,
cst' from subtyping,
constraints from module type. *)
diff --git a/kernel/modops.ml b/kernel/modops.ml
index a079bc8931..76915e917a 100644
--- a/kernel/modops.ml
+++ b/kernel/modops.ml
@@ -143,11 +143,12 @@ let rec functor_iter fty f0 = function
(** {6 Misc operations } *)
let module_type_of_module mb =
- { mb with mod_expr = Abstract; mod_type_alg = None }
+ { mb with mod_expr = (); mod_type_alg = None;
+ mod_retroknowledge = ModTypeRK; }
let module_body_of_type mp mtb =
- assert (mtb.mod_expr == Abstract);
- { mtb with mod_mp = mp }
+ { mtb with mod_expr = Abstract; mod_mp = mp;
+ mod_retroknowledge = ModBodyRK []; }
let check_modpath_equiv env mp1 mp2 =
if ModPath.equal mp1 mp2 then ()
@@ -196,7 +197,8 @@ let rec subst_structure sub do_delta sign =
in
List.smartmap subst_body sign
-and subst_body is_mod sub do_delta mb =
+and subst_body : 'a. _ -> _ -> (_ -> 'a -> 'a) -> _ -> 'a generic_module_body -> 'a generic_module_body =
+ fun is_mod sub subst_impl do_delta mb ->
let { mod_mp=mp; mod_expr=me; mod_type=ty; mod_type_alg=aty } = mb in
let mp' = subst_mp sub mp in
let sub =
@@ -205,10 +207,7 @@ and subst_body is_mod sub do_delta mb =
else add_mp mp mp' empty_delta_resolver sub
in
let ty' = subst_signature sub do_delta ty in
- let me' =
- implem_smartmap
- (subst_signature sub id_delta) (subst_expression sub id_delta) me
- in
+ let me' = subst_impl sub me in
let aty' = Option.smartmap (subst_expression sub id_delta) aty in
let delta' = do_delta mb.mod_delta sub in
if mp==mp' && me==me' && ty==ty' && aty==aty' && delta'==mb.mod_delta
@@ -221,9 +220,14 @@ and subst_body is_mod sub do_delta mb =
mod_type_alg = aty';
mod_delta = delta' }
-and subst_module sub do_delta mb = subst_body true sub do_delta mb
+and subst_module sub do_delta mb =
+ subst_body true sub subst_impl do_delta mb
+
+and subst_impl sub me =
+ implem_smartmap
+ (subst_signature sub id_delta) (subst_expression sub id_delta) me
-and subst_modtype sub do_delta mtb = subst_body false sub do_delta mtb
+and subst_modtype sub do_delta mtb = subst_body false sub (fun _ () -> ()) do_delta mtb
and subst_expr sub do_delta seb = match seb with
|MEident mp ->
@@ -268,7 +272,7 @@ let add_retroknowledge mp =
CErrors.anomaly ~label:"Modops.add_retroknowledge"
(Pp.str "had to import an unsupported kind of term.")
in
- fun lclrk env ->
+ fun (ModBodyRK lclrk) env ->
(* The order of the declaration matters, for instance (and it's at the
time this comment is being written, the only relevent instance) the
int31 type registration absolutely needs int31 bits to be registered.
@@ -567,7 +571,7 @@ let rec is_bounded_expr l = function
is_bounded_expr l (MEident mp) || is_bounded_expr l fexpr
| _ -> false
-let rec clean_module l mb =
+let rec clean_module_body l mb =
let impl, typ = mb.mod_expr, mb.mod_type in
let typ' = clean_signature l typ in
let impl' = match impl with
@@ -577,19 +581,25 @@ let rec clean_module l mb =
if typ==typ' && impl==impl' then mb
else { mb with mod_type=typ'; mod_expr=impl' }
+and clean_module_type l mb =
+ let (), typ = mb.mod_expr, mb.mod_type in
+ let typ' = clean_signature l typ in
+ if typ==typ' then mb
+ else { mb with mod_type=typ' }
+
and clean_field l field = match field with
|(lab,SFBmodule mb) ->
- let mb' = clean_module l mb in
+ let mb' = clean_module_body l mb in
if mb==mb' then field else (lab,SFBmodule mb')
|_ -> field
and clean_structure l = List.smartmap (clean_field l)
and clean_signature l =
- functor_smartmap (clean_module l) (clean_structure l)
+ functor_smartmap (clean_module_type l) (clean_structure l)
and clean_expression l =
- functor_smartmap (clean_module l) (fun me -> me)
+ functor_smartmap (clean_module_type l) (fun me -> me)
let rec collect_mbid l sign = match sign with
|MoreFunctor (mbid,ty,m) ->
@@ -613,14 +623,16 @@ let join_constant_body except otab cb =
| _ -> ()
let join_structure except otab s =
- let rec join_module mb =
- implem_iter join_signature join_expression mb.mod_expr;
+ let rec join_module : 'a. 'a generic_module_body -> unit = fun mb ->
Option.iter join_expression mb.mod_type_alg;
join_signature mb.mod_type
and join_field (l,body) = match body with
|SFBconst sb -> join_constant_body except otab sb
|SFBmind _ -> ()
- |SFBmodule m |SFBmodtype m -> join_module m
+ |SFBmodule m ->
+ implem_iter join_signature join_expression m.mod_expr;
+ join_module m
+ |SFBmodtype m -> join_module m
and join_structure struc = List.iter join_field struc
and join_signature sign =
functor_iter join_module join_structure sign
diff --git a/kernel/nativeconv.ml b/kernel/nativeconv.ml
index d2f050d3bc..a62a079da9 100644
--- a/kernel/nativeconv.ml
+++ b/kernel/nativeconv.ml
@@ -132,7 +132,7 @@ let native_conv_gen pb sigma env univs t1 t2 =
let penv = Environ.pre_env env in
let ml_filename, prefix = get_ml_filename () in
let code, upds = mk_conv_code penv sigma prefix t1 t2 in
- match compile ml_filename code with
+ match compile ml_filename code ~profile:false with
| (true, fn) ->
begin
if !Flags.debug then Feedback.msg_debug (Pp.str "Running test...");
diff --git a/kernel/nativelib.ml b/kernel/nativelib.ml
index 02e02b031a..665ddf7a65 100644
--- a/kernel/nativelib.ml
+++ b/kernel/nativelib.ml
@@ -64,7 +64,7 @@ let warn_native_compiler_failed =
in
CWarnings.create ~name:"native-compiler-failed" ~category:"native-compiler" print
-let call_compiler ml_filename =
+let call_compiler ?profile:(profile=false) ml_filename =
let load_path = !get_load_paths () in
let load_path = List.map (fun dn -> dn / output_dir) load_path in
let include_dirs = List.flatten (List.map (fun x -> ["-I"; x]) (include_dirs () @ load_path)) in
@@ -74,14 +74,26 @@ let call_compiler ml_filename =
let remove f = if Sys.file_exists f then Sys.remove f in
remove link_filename;
remove (f ^ ".cmi");
+ let initial_args =
+ if Dynlink.is_native then
+ ["opt"; "-shared"]
+ else
+ ["ocamlc"; "-c"]
+ in
+ let profile_args =
+ if profile then
+ ["-g"]
+ else
+ []
+ in
let args =
- (if Dynlink.is_native then "opt" else "ocamlc")
- ::(if Dynlink.is_native then "-shared" else "-c")
- ::"-o"::link_filename
- ::"-rectypes"
- ::"-w"::"a"
- ::include_dirs
- @ ["-impl"; ml_filename] in
+ initial_args @
+ profile_args @
+ ("-o"::link_filename
+ ::"-rectypes"
+ ::"-w"::"a"
+ ::include_dirs) @
+ ["-impl"; ml_filename] in
if !Flags.debug then Feedback.msg_debug (Pp.str (ocamlfind () ^ " " ^ (String.concat " " args)));
try
let res = CUnix.sys_command (ocamlfind ()) args in
@@ -95,9 +107,9 @@ let call_compiler ml_filename =
warn_native_compiler_failed (Inr e);
false, link_filename
-let compile fn code =
+let compile fn code ~profile:profile =
write_ml_code fn code;
- let r = call_compiler fn in
+ let r = call_compiler ~profile fn in
if (not !Flags.debug) && Sys.file_exists fn then Sys.remove fn;
r
diff --git a/kernel/nativelib.mli b/kernel/nativelib.mli
index e8b51dc366..a262a9f58a 100644
--- a/kernel/nativelib.mli
+++ b/kernel/nativelib.mli
@@ -19,7 +19,7 @@ val load_obj : (string -> unit) ref
val get_ml_filename : unit -> string * string
-val compile : string -> global list -> bool * string
+val compile : string -> global list -> profile:bool -> bool * string
val compile_library : Names.dir_path -> global list -> string -> bool
diff --git a/kernel/pre_env.ml b/kernel/pre_env.ml
index 7b4fb4e869..94738d6186 100644
--- a/kernel/pre_env.ml
+++ b/kernel/pre_env.ml
@@ -156,7 +156,7 @@ let map_named_val f ctxt =
in
(accu, d')
in
- let map, ctx = List.fold_map fold ctxt.env_named_map ctxt.env_named_ctx in
+ let map, ctx = List.fold_left_map fold ctxt.env_named_map ctxt.env_named_ctx in
if map == ctxt.env_named_map then ctxt
else { env_named_ctx = ctx; env_named_map = map }
diff --git a/kernel/safe_typing.ml b/kernel/safe_typing.ml
index 04051f2e23..ad622b07d8 100644
--- a/kernel/safe_typing.ml
+++ b/kernel/safe_typing.ml
@@ -574,7 +574,7 @@ let add_mind dir l mie senv =
let add_modtype l params_mte inl senv =
let mp = MPdot(senv.modpath, l) in
let mtb = Mod_typing.translate_modtype senv.env mp inl params_mte in
- let mtb = Declareops.hcons_module_body mtb in
+ let mtb = Declareops.hcons_module_type mtb in
let senv' = add_field (l,SFBmodtype mtb) MT senv in
mp, senv'
@@ -677,7 +677,7 @@ let build_module_body params restype senv =
(struc,None,senv.modresolver,senv.univ) restype'
in
let mb' = functorize_module params mb in
- { mb' with mod_retroknowledge = senv.local_retroknowledge }
+ { mb' with mod_retroknowledge = ModBodyRK senv.local_retroknowledge }
(** Returning back to the old pre-interactive-module environment,
with one extra component and some updated fields
@@ -732,12 +732,12 @@ let end_module l restype senv =
let build_mtb mp sign cst delta =
{ mod_mp = mp;
- mod_expr = Abstract;
+ mod_expr = ();
mod_type = sign;
mod_type_alg = None;
mod_constraints = cst;
mod_delta = delta;
- mod_retroknowledge = [] }
+ mod_retroknowledge = ModTypeRK }
let end_modtype l senv =
let mp = senv.modpath in
@@ -853,7 +853,7 @@ let export ?except senv dir =
mod_type_alg = None;
mod_constraints = senv.univ;
mod_delta = senv.modresolver;
- mod_retroknowledge = senv.local_retroknowledge
+ mod_retroknowledge = ModBodyRK senv.local_retroknowledge
}
in
let ast, symbols =
diff --git a/kernel/subtyping.ml b/kernel/subtyping.ml
index b311165f10..b564b2a8c1 100644
--- a/kernel/subtyping.ml
+++ b/kernel/subtyping.ml
@@ -416,7 +416,7 @@ and check_modtypes cst env mtb1 mtb2 subst1 subst2 equiv =
mod_type = subst_signature subst1 body_t1;
mod_type_alg = None;
mod_constraints = mtb1.mod_constraints;
- mod_retroknowledge = [];
+ mod_retroknowledge = ModBodyRK [];
mod_delta = mtb1.mod_delta} env
in
check_structure cst env body_t1 body_t2 equiv subst1 subst2
diff --git a/kernel/univ.ml b/kernel/univ.ml
index d915fb8c98..bae782f5d4 100644
--- a/kernel/univ.ml
+++ b/kernel/univ.ml
@@ -31,133 +31,6 @@ open Util
union-find algorithm. The assertions $<$ and $\le$ are represented by
adjacency lists *)
-module type Hashconsed =
-sig
- type t
- val hash : t -> int
- val eq : t -> t -> bool
- val hcons : t -> t
-end
-
-module HashedList (M : Hashconsed) :
-sig
- type t = private Nil | Cons of M.t * int * t
- val nil : t
- val cons : M.t -> t -> t
-end =
-struct
- type t = Nil | Cons of M.t * int * t
- module Self =
- struct
- type _t = t
- type t = _t
- type u = (M.t -> M.t)
- let hash = function Nil -> 0 | Cons (_, h, _) -> h
- let eq l1 l2 = match l1, l2 with
- | Nil, Nil -> true
- | Cons (x1, _, l1), Cons (x2, _, l2) -> x1 == x2 && l1 == l2
- | _ -> false
- let hashcons hc = function
- | Nil -> Nil
- | Cons (x, h, l) -> Cons (hc x, h, l)
- end
- module Hcons = Hashcons.Make(Self)
- let hcons = Hashcons.simple_hcons Hcons.generate Hcons.hcons M.hcons
- (** No recursive call: the interface guarantees that all HLists from this
- program are already hashconsed. If we get some external HList, we can
- still reconstruct it by traversing it entirely. *)
- let nil = Nil
- let cons x l =
- let h = M.hash x in
- let hl = match l with Nil -> 0 | Cons (_, h, _) -> h in
- let h = Hashset.Combine.combine h hl in
- hcons (Cons (x, h, l))
-end
-
-module HList = struct
-
- module type S = sig
- type elt
- type t = private Nil | Cons of elt * int * t
- val hash : t -> int
- val nil : t
- val cons : elt -> t -> t
- val tip : elt -> t
- val fold : (elt -> 'a -> 'a) -> t -> 'a -> 'a
- val map : (elt -> elt) -> t -> t
- val smartmap : (elt -> elt) -> t -> t
- val exists : (elt -> bool) -> t -> bool
- val for_all : (elt -> bool) -> t -> bool
- val for_all2 : (elt -> elt -> bool) -> t -> t -> bool
- val mem : elt -> t -> bool
- val remove : elt -> t -> t
- val to_list : t -> elt list
- val compare : (elt -> elt -> int) -> t -> t -> int
- end
-
- module Make (H : Hashconsed) : S with type elt = H.t =
- struct
- type elt = H.t
- include HashedList(H)
-
- let hash = function Nil -> 0 | Cons (_, h, _) -> h
-
- let tip e = cons e nil
-
- let rec fold f l accu = match l with
- | Nil -> accu
- | Cons (x, _, l) -> fold f l (f x accu)
-
- let rec map f = function
- | Nil -> nil
- | Cons (x, _, l) -> cons (f x) (map f l)
-
- let smartmap = map
- (** Apriori hashconsing ensures that the map is equal to its argument *)
-
- let rec exists f = function
- | Nil -> false
- | Cons (x, _, l) -> f x || exists f l
-
- let rec for_all f = function
- | Nil -> true
- | Cons (x, _, l) -> f x && for_all f l
-
- let rec for_all2 f l1 l2 = match l1, l2 with
- | Nil, Nil -> true
- | Cons (x1, _, l1), Cons (x2, _, l2) -> f x1 x2 && for_all2 f l1 l2
- | _ -> false
-
- let rec to_list = function
- | Nil -> []
- | Cons (x, _, l) -> x :: to_list l
-
- let rec remove x = function
- | Nil -> nil
- | Cons (y, _, l) ->
- if H.eq x y then l
- else cons y (remove x l)
-
- let rec mem x = function
- | Nil -> false
- | Cons (y, _, l) -> H.eq x y || mem x l
-
- let rec compare cmp l1 l2 = match l1, l2 with
- | Nil, Nil -> 0
- | Cons (x1, h1, l1), Cons (x2, h2, l2) ->
- let c = Int.compare h1 h2 in
- if c == 0 then
- let c = cmp x1 x2 in
- if c == 0 then
- compare cmp l1 l2
- else c
- else c
- | Cons _, Nil -> 1
- | Nil, Cons _ -> -1
-
- end
-end
-
module RawLevel =
struct
open Names
@@ -390,12 +263,11 @@ struct
module Expr =
struct
type t = Level.t * int
- type _t = t
(* Hashing of expressions *)
module ExprHash =
struct
- type t = _t
+ type t = Level.t * int
type u = Level.t -> Level.t
let hashcons hdir (b,n as x) =
let b' = hdir b in
@@ -409,25 +281,12 @@ struct
end
- module HExpr =
- struct
-
- module H = Hashcons.Make(ExprHash)
-
- type t = ExprHash.t
-
- let hcons =
- Hashcons.simple_hcons H.generate H.hcons Level.hcons
- let hash = ExprHash.hash
- let eq x y = x == y ||
- (let (u,n) = x and (v,n') = y in
- Int.equal n n' && Level.equal u v)
-
- end
+ module H = Hashcons.Make(ExprHash)
- let hcons = HExpr.hcons
+ let hcons =
+ Hashcons.simple_hcons H.generate H.hcons Level.hcons
- let make l = hcons (l, 0)
+ let make l = (l, 0)
let compare u v =
if u == v then 0
@@ -436,8 +295,8 @@ struct
if Int.equal n n' then Level.compare x x'
else n - n'
- let prop = make Level.prop
- let set = make Level.set
+ let prop = hcons (Level.prop, 0)
+ let set = hcons (Level.set, 0)
let type1 = hcons (Level.set, 1)
let is_small = function
@@ -448,6 +307,8 @@ struct
(let (u,n) = x and (v,n') = y in
Int.equal n n' && Level.equal u v)
+ let hash = ExprHash.hash
+
let leq (u,n) (v,n') =
let cmp = Level.compare u v in
if Int.equal cmp 0 then n <= n'
@@ -457,13 +318,13 @@ struct
let successor (u,n) =
if Level.is_prop u then type1
- else hcons (u, n + 1)
+ else (u, n + 1)
let addn k (u,n as x) =
if k = 0 then x
else if Level.is_prop u then
- hcons (Level.set,n+k)
- else hcons (u,n+k)
+ (Level.set,n+k)
+ else (u,n+k)
type super_result =
SuperSame of bool
@@ -515,71 +376,63 @@ struct
let v' = f v in
if v' == v then x
else if Level.is_prop v' && n != 0 then
- hcons (Level.set, n)
- else hcons (v', n)
+ (Level.set, n)
+ else (v', n)
end
-
- let compare_expr = Expr.compare
- module Huniv = HList.Make(Expr.HExpr)
- type t = Huniv.t
- open Huniv
-
- let equal x y = x == y ||
- (Huniv.hash x == Huniv.hash y &&
- Huniv.for_all2 Expr.equal x y)
+ type t = Expr.t list
- let hash = Huniv.hash
+ let tip l = [l]
+ let cons x l = x :: l
- let compare x y =
- if x == y then 0
- else
- let hx = Huniv.hash x and hy = Huniv.hash y in
- let c = Int.compare hx hy in
- if c == 0 then
- Huniv.compare (fun e1 e2 -> compare_expr e1 e2) x y
- else c
+ let rec hash = function
+ | [] -> 0
+ | e :: l -> Hashset.Combine.combinesmall (Expr.ExprHash.hash e) (hash l)
+
+ let equal x y = x == y || List.equal Expr.equal x y
+
+ let compare x y = if x == y then 0 else List.compare Expr.compare x y
+
+ module Huniv = Hashcons.Hlist(Expr)
- let rec hcons = function
- | Nil -> Huniv.nil
- | Cons (x, _, l) -> Huniv.cons x (hcons l)
+ let hcons = Hashcons.recursive_hcons Huniv.generate Huniv.hcons Expr.hcons
- let make l = Huniv.tip (Expr.make l)
- let tip x = Huniv.tip x
+ let make l = tip (Expr.make l)
+ let tip x = tip x
let pr l = match l with
- | Cons (u, _, Nil) -> Expr.pr u
+ | [u] -> Expr.pr u
| _ ->
str "max(" ++ hov 0
- (prlist_with_sep pr_comma Expr.pr (to_list l)) ++
+ (prlist_with_sep pr_comma Expr.pr l) ++
str ")"
let pr_with f l = match l with
- | Cons (u, _, Nil) -> Expr.pr_with f u
+ | [u] -> Expr.pr_with f u
| _ ->
str "max(" ++ hov 0
- (prlist_with_sep pr_comma (Expr.pr_with f) (to_list l)) ++
+ (prlist_with_sep pr_comma (Expr.pr_with f) l) ++
str ")"
let is_level l = match l with
- | Cons (l, _, Nil) -> Expr.is_level l
+ | [l] -> Expr.is_level l
| _ -> false
let rec is_levels l = match l with
- | Cons (l, _, r) -> Expr.is_level l && is_levels r
- | Nil -> true
+ | l :: r -> Expr.is_level l && is_levels r
+ | [] -> true
let level l = match l with
- | Cons (l, _, Nil) -> Expr.level l
+ | [l] -> Expr.level l
| _ -> None
let levels l =
- fold (fun x acc -> LSet.add (Expr.get_level x) acc) l LSet.empty
+ List.fold_left (fun acc x -> LSet.add (Expr.get_level x) acc) LSet.empty l
let is_small u =
match u with
- | Cons (l, _, Nil) -> Expr.is_small l
+ | [l] -> Expr.is_small l
| _ -> false
(* The lower predicative level of the hierarchy that contains (impredicative)
@@ -601,16 +454,16 @@ struct
let super l =
if is_small l then type1
else
- Huniv.map (fun x -> Expr.successor x) l
+ List.smartmap (fun x -> Expr.successor x) l
let addn n l =
- Huniv.map (fun x -> Expr.addn n x) l
+ List.smartmap (fun x -> Expr.addn n x) l
let rec merge_univs l1 l2 =
match l1, l2 with
- | Nil, _ -> l2
- | _, Nil -> l1
- | Cons (h1, _, t1), Cons (h2, _, t2) ->
+ | [], _ -> l2
+ | _, [] -> l1
+ | h1 :: t1, h2 :: t2 ->
let open Expr in
(match super h1 h2 with
| SuperSame true (* h1 < h2 *) -> merge_univs t1 l2
@@ -623,7 +476,7 @@ struct
let sort u =
let rec aux a l =
match l with
- | Cons (b, _, l') ->
+ | b :: l' ->
let open Expr in
(match super a b with
| SuperSame false -> aux a l'
@@ -631,21 +484,21 @@ struct
| SuperDiff c ->
if c <= 0 then cons a l
else cons b (aux a l'))
- | Nil -> cons a l
+ | [] -> cons a l
in
- fold (fun a acc -> aux a acc) u nil
+ List.fold_right (fun a acc -> aux a acc) u []
(* Returns the formal universe that is greater than the universes u and v.
Used to type the products. *)
let sup x y = merge_univs x y
- let empty = nil
+ let empty = []
- let exists = Huniv.exists
+ let exists = List.exists
- let for_all = Huniv.for_all
+ let for_all = List.for_all
- let smartmap = Huniv.smartmap
+ let smartmap = List.smartmap
end
@@ -818,12 +671,11 @@ let check_univ_leq u v =
Universe.for_all (fun u -> check_univ_leq_one u v) u
let enforce_leq u v c =
- let open Universe.Huniv in
let rec aux acc v =
match v with
- | Cons (v, _, l) ->
- aux (fold (fun u -> constraint_add_leq u v) u c) l
- | Nil -> acc
+ | v :: l ->
+ aux (List.fold_right (fun u -> constraint_add_leq u v) u c) l
+ | [] -> acc
in aux c v
let enforce_leq u v c =
@@ -842,12 +694,13 @@ let enforce_univ_constraint (u,d,v) =
(* Miscellaneous functions to remove or test local univ assumed to
occur in a universe *)
-let univ_level_mem u v = Huniv.mem (Expr.make u) v
+let univ_level_mem u v =
+ List.exists (fun (l, n) -> Int.equal n 0 && Level.equal u l) v
let univ_level_rem u v min =
match Universe.level v with
| Some u' -> if Level.equal u u' then min else v
- | None -> Huniv.remove (Universe.Expr.make u) v
+ | None -> List.filter (fun (l, n) -> not (Int.equal n 0 && Level.equal u l)) v
(* Is u mentionned in v (or equals to v) ? *)
@@ -1260,7 +1113,7 @@ let subst_univs_expr_opt fn (l,n) =
let subst_univs_universe fn ul =
let subst, nosubst =
- Universe.Huniv.fold (fun u (subst,nosubst) ->
+ List.fold_right (fun u (subst,nosubst) ->
try let a' = subst_univs_expr_opt fn u in
(a' :: subst, nosubst)
with Not_found -> (subst, u :: nosubst))
@@ -1271,7 +1124,7 @@ let subst_univs_universe fn ul =
let substs =
List.fold_left Universe.merge_univs Universe.empty subst
in
- List.fold_left (fun acc u -> Universe.merge_univs acc (Universe.Huniv.tip u))
+ List.fold_left (fun acc u -> Universe.merge_univs acc (Universe.tip u))
substs nosubst
let subst_univs_level fn l =
generated by cgit v1.2.3 (git 2.25.1) at 2026-05-01 07:04:39 +0000