aboutsummaryrefslogtreecommitdiff
path: root/kernel
diff options
context:
space:
mode:
Diffstat (limited to 'kernel')
-rw-r--r--kernel/cbytecodes.ml20
-rw-r--r--kernel/cbytecodes.mli5
-rw-r--r--kernel/cbytegen.ml33
-rw-r--r--kernel/csymtable.ml14
-rw-r--r--kernel/nativecode.ml34
5 files changed, 66 insertions, 40 deletions
diff --git a/kernel/cbytecodes.ml b/kernel/cbytecodes.ml
index a705e3004f..8d4de523a1 100644
--- a/kernel/cbytecodes.ml
+++ b/kernel/cbytecodes.ml
@@ -142,11 +142,29 @@ type fv = fv_elem array
exception NotClosed
+module Fv_elem =
+struct
+type t = fv_elem
+
+let compare e1 e2 = match e1, e2 with
+| FVnamed id1, FVnamed id2 -> Id.compare id1 id2
+| FVnamed _, _ -> -1
+| FVrel _, FVnamed _ -> 1
+| FVrel r1, FVrel r2 -> Int.compare r1 r2
+| FVrel _, FVuniv_var _ -> -1
+| FVuniv_var i1, FVuniv_var i2 -> Int.compare i1 i2
+| FVuniv_var i1, _ -> 1
+
+end
+
+module FvMap = Map.Make(Fv_elem)
+
(*spiwack: both type have been moved from Cbytegen because I needed then
for the retroknowledge *)
type vm_env = {
size : int; (* longueur de la liste [n] *)
- fv_rev : fv_elem list (* [fvn; ... ;fv1] *)
+ fv_rev : fv_elem list; (* [fvn; ... ;fv1] *)
+ fv_fwd : int FvMap.t; (* reverse mapping *)
}
diff --git a/kernel/cbytecodes.mli b/kernel/cbytecodes.mli
index 6fa0841af9..5f1f09d00c 100644
--- a/kernel/cbytecodes.mli
+++ b/kernel/cbytecodes.mli
@@ -139,11 +139,14 @@ type fv = fv_elem array
closed terms. *)
exception NotClosed
+module FvMap : Map.S with type key = fv_elem
+
(*spiwack: both type have been moved from Cbytegen because I needed them
for the retroknowledge *)
type vm_env = {
size : int; (** length of the list [n] *)
- fv_rev : fv_elem list (** [fvn; ... ;fv1] *)
+ fv_rev : fv_elem list; (** [fvn; ... ;fv1] *)
+ fv_fwd : int FvMap.t; (** reverse mapping *)
}
diff --git a/kernel/cbytegen.ml b/kernel/cbytegen.ml
index 2d1ae68f4b..008955d804 100644
--- a/kernel/cbytegen.ml
+++ b/kernel/cbytegen.ml
@@ -93,7 +93,12 @@ open Pre_env
type argument = ArgConstr of Constr.t | ArgUniv of Univ.Level.t
-let empty_fv = { size= 0; fv_rev = [] }
+let empty_fv = { size= 0; fv_rev = []; fv_fwd = FvMap.empty }
+let push_fv d e = {
+ size = e.size + 1;
+ fv_rev = d :: e.fv_rev;
+ fv_fwd = FvMap.add d e.size e.fv_fwd;
+}
let fv r = !(r.in_env)
@@ -184,20 +189,15 @@ let push_local sz r =
in_stack = (sz + 1) :: r.in_stack }
(*i Compilation of variables *)
-let find_at f l =
- let rec aux n = function
- | [] -> raise Not_found
- | hd :: tl -> if f hd then n else aux (n + 1) tl
- in aux 1 l
+let find_at fv env = FvMap.find fv env.fv_fwd
let pos_named id r =
let env = !(r.in_env) in
let cid = FVnamed id in
- let f = function FVnamed id' -> Id.equal id id' | _ -> false in
- try Kenvacc(r.offset + env.size - (find_at f env.fv_rev))
+ try Kenvacc(r.offset + find_at cid env)
with Not_found ->
let pos = env.size in
- r.in_env := { size = pos+1; fv_rev = cid:: env.fv_rev};
+ r.in_env := push_fv cid env;
Kenvacc (r.offset + pos)
let pos_rel i r sz =
@@ -212,11 +212,10 @@ let pos_rel i r sz =
let i = i - r.nb_rec in
let db = FVrel(i) in
let env = !(r.in_env) in
- let f = function FVrel j -> Int.equal i j | _ -> false in
- try Kenvacc(r.offset + env.size - (find_at f env.fv_rev))
+ try Kenvacc(r.offset + find_at db env)
with Not_found ->
let pos = env.size in
- r.in_env := { size = pos+1; fv_rev = db:: env.fv_rev};
+ r.in_env := push_fv db env;
Kenvacc(r.offset + pos)
let pos_universe_var i r sz =
@@ -224,15 +223,11 @@ let pos_universe_var i r sz =
Kacc (sz - r.nb_stack - (r.nb_uni_stack - i))
else
let env = !(r.in_env) in
- let f = function
- | FVuniv_var u -> Int.equal i u
- | _ -> false
- in
- try Kenvacc (r.offset + env.size - (find_at f env.fv_rev))
+ let db = FVuniv_var i in
+ try Kenvacc (r.offset + find_at db env)
with Not_found ->
let pos = env.size in
- let db = FVuniv_var i in
- r.in_env := { size = pos + 1; fv_rev = db::env.fv_rev } ;
+ r.in_env := push_fv db env;
Kenvacc(r.offset + pos)
(*i Examination of the continuation *)
diff --git a/kernel/csymtable.ml b/kernel/csymtable.ml
index acd73d97d7..e195618b6b 100644
--- a/kernel/csymtable.ml
+++ b/kernel/csymtable.ml
@@ -219,17 +219,9 @@ and eval_to_patch env (buff,pl,fv) =
eval_tcode tc vm_env
and val_of_constr env c =
- let (_,fun_code,_ as ccfv) =
- try match compile true env c with
- | Some v -> v
- | None -> assert false
- with reraise ->
- let reraise = CErrors.push reraise in
- let () = print_string "can not compile \n" in
- let () = Format.print_flush () in
- iraise reraise
- in
- eval_to_patch env (to_memory ccfv)
+ match compile true env c with
+ | Some v -> eval_to_patch env (to_memory v)
+ | None -> assert false
let set_transparent_const kn = () (* !?! *)
let set_opaque_const kn = () (* !?! *)
diff --git a/kernel/nativecode.ml b/kernel/nativecode.ml
index e2f43b93ee..ad5b04f3d1 100644
--- a/kernel/nativecode.ml
+++ b/kernel/nativecode.ml
@@ -22,8 +22,12 @@ to OCaml code. *)
(** Local names **)
+(* The first component is there for debugging purposes only *)
type lname = { lname : name; luid : int }
+let eq_lname ln1 ln2 =
+ Int.equal ln1.luid ln2.luid
+
let dummy_lname = { lname = Anonymous; luid = -1 }
module LNord =
@@ -82,6 +86,9 @@ let eq_gname gn1 gn2 =
| Gnamed id1, Gnamed id2 -> Id.equal id1 id2
| _ -> false
+let dummy_gname =
+ Grel 0
+
open Hashset.Combine
let gname_hash gn = match gn with
@@ -404,9 +411,13 @@ let opush_lnames n env lns =
let rec eq_mllambda gn1 gn2 n env1 env2 t1 t2 =
match t1, t2 with
| MLlocal ln1, MLlocal ln2 ->
+ (try
Int.equal (LNmap.find ln1 env1) (LNmap.find ln2 env2)
+ with Not_found ->
+ eq_lname ln1 ln2)
| MLglobal gn1', MLglobal gn2' ->
eq_gname gn1' gn2' || (eq_gname gn1 gn1' && eq_gname gn2 gn2')
+ || (eq_gname gn1 gn2' && eq_gname gn2 gn1')
| MLprimitive prim1, MLprimitive prim2 -> eq_primitive prim1 prim2
| MLlam (lns1, ml1), MLlam (lns2, ml2) ->
Int.equal (Array.length lns1) (Array.length lns2) &&
@@ -719,6 +730,11 @@ let push_global_norm gn params body =
let push_global_case gn params annot a accu bs =
push_global gn (Gletcase (gn, params, annot, a, accu, bs))
+(* Compares [t1] and [t2] up to alpha-equivalence. [t1] and [t2] may contain
+ free variables. *)
+let eq_mllambda t1 t2 =
+ eq_mllambda dummy_gname dummy_gname 0 LNmap.empty LNmap.empty t1 t2
+
(*s Compilation environment *)
type env =
@@ -897,9 +913,7 @@ let rec insert cargs body rl =
let params = rm_params fv params in
rl:= Rcons(ref [(c,params)], fv, body, ref Rnil)
| Rcons(l,fv,body',rl) ->
- (** ppedrot: It seems we only want to factorize common branches. It should
- not matter to do so with a subapproximation by (==). *)
- if body == body' then
+ if eq_mllambda body body' then
let (c,params) = cargs in
let params = rm_params fv params in
l := (c,params)::!l
@@ -1446,12 +1460,14 @@ let optimize gdef l =
end
| MLif(t,b1,b2) ->
+ (* This optimization is critical: it applies to all fixpoints that start
+ by matching on their recursive argument *)
let t = optimize s t in
let b1 = optimize s b1 in
let b2 = optimize s b2 in
begin match t, b2 with
| MLapp(MLprimitive Is_accu,[| l1 |]), MLmatch(annot, l2, _, bs)
- when l1 == l2 -> MLmatch(annot, l1, b1, bs) (** approximation *)
+ when eq_mllambda l1 l2 -> MLmatch(annot, l1, b1, bs)
| _, _ -> MLif(t, b1, b2)
end
| MLmatch(annot,a,accu,bs) ->
@@ -1930,13 +1946,15 @@ let compile_constant env sigma prefix ~interactive con cb =
arg|])))::
[Glet(gn, mkMLlam [|c_uid|] code)], Linked prefix
-let loaded_native_files = ref ([] : string list)
+module StringOrd = struct type t = string let compare = String.compare end
+module StringSet = Set.Make(StringOrd)
+
+let loaded_native_files = ref StringSet.empty
-let is_loaded_native_file s = String.List.mem s !loaded_native_files
+let is_loaded_native_file s = StringSet.mem s !loaded_native_files
let register_native_file s =
- if not (is_loaded_native_file s) then
- loaded_native_files := s :: !loaded_native_files
+ loaded_native_files := StringSet.add s !loaded_native_files
let is_code_loaded ~interactive name =
match !name with
generated by cgit v1.2.3 (git 2.25.1) at 2026-05-02 05:31:49 +0000