diff options
Diffstat (limited to 'kernel/nativecode.ml')
| -rw-r--r-- | kernel/nativecode.ml | 72 |
1 files changed, 45 insertions, 27 deletions
diff --git a/kernel/nativecode.ml b/kernel/nativecode.ml index 9d181b47..eaddace4 100644 --- a/kernel/nativecode.ml +++ b/kernel/nativecode.ml @@ -5,10 +5,10 @@ (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -open Errors + +open CErrors open Names open Term -open Context open Declarations open Util open Nativevalues @@ -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) -> @@ -1487,8 +1503,8 @@ let optimize_stk stk = (** Printing to ocaml **) (* Redefine a bunch of functions in module Names to generate names acceptable to OCaml. *) -let string_of_id s = Unicode.ascii_of_ident (string_of_id s) -let string_of_label l = Unicode.ascii_of_ident (string_of_label l) +let string_of_id s = Unicode.ascii_of_ident (Id.to_string s) +let string_of_label l = string_of_id (Label.to_id l) let string_of_dirpath = function | [] -> "_" @@ -1561,8 +1577,7 @@ let pp_gname fmt g = Format.fprintf fmt "%s" (string_of_gname g) let pp_lname fmt ln = - let s = Unicode.ascii_of_ident (string_of_name ln.lname) in - Format.fprintf fmt "x_%s_%i" s ln.luid + Format.fprintf fmt "x_%s_%i" (string_of_name ln.lname) ln.luid let pp_ldecls fmt ids = let len = Array.length ids in @@ -1826,31 +1841,32 @@ and apply_fv env sigma univ (fv_named,fv_rel) auxdefs ml = in let auxdefs = List.fold_right get_rel_val fv_rel auxdefs in let auxdefs = List.fold_right get_named_val fv_named auxdefs in - let lvl = rel_context_length env.env_rel_context in + let lvl = Context.Rel.length env.env_rel_context in let fv_rel = List.map (fun (n,_) -> MLglobal (Grel (lvl-n))) fv_rel in let fv_named = List.map (fun (id,_) -> MLglobal (Gnamed id)) fv_named in let aux_name = fresh_lname Anonymous in auxdefs, MLlet(aux_name, ml, mkMLapp (MLlocal aux_name) (Array.of_list (fv_rel@fv_named))) and compile_rel env sigma univ auxdefs n = - let (_,body,_) = lookup_rel n env.env_rel_context in - let n = rel_context_length env.env_rel_context - n in - match body with - | Some t -> + let open Context.Rel in + let n = length env.env_rel_context - n in + let open Declaration in + match lookup n env.env_rel_context with + | LocalDef (_,t,_) -> let code = lambda_of_constr env sigma t in let auxdefs,code = compile_with_fv env sigma univ auxdefs None code in Glet(Grel n, code)::auxdefs - | None -> + | LocalAssum _ -> Glet(Grel n, MLprimitive (Mk_rel n))::auxdefs and compile_named env sigma univ auxdefs id = - let (_,body,_) = lookup_named id env.env_named_context in - match body with - | Some t -> + let open Context.Named.Declaration in + match lookup_named id env with + | LocalDef (_,t,_) -> let code = lambda_of_constr env sigma t in let auxdefs,code = compile_with_fv env sigma univ auxdefs None code in Glet(Gnamed id, code)::auxdefs - | None -> + | LocalAssum _ -> Glet(Gnamed id, MLprimitive (Mk_var id))::auxdefs let compile_constant env sigma prefix ~interactive con cb = @@ -1864,7 +1880,7 @@ let compile_constant env sigma prefix ~interactive con cb = | Def t -> let t = Mod_subst.force_constr t in let code = lambda_of_constr env sigma t in - if !Flags.debug then Pp.msg_debug (Pp.str "Generated lambda code"); + if !Flags.debug then Feedback.msg_debug (Pp.str "Generated lambda code"); let is_lazy = is_lazy prefix t in let code = if is_lazy then mk_lazy code else code in let name = @@ -1879,11 +1895,11 @@ let compile_constant env sigma prefix ~interactive con cb = let (auxdefs,code) = compile_with_fv env sigma (Some univ) [] (Some l) code in (auxdefs,mkMLlam [|univ|] code) in - if !Flags.debug then Pp.msg_debug (Pp.str "Generated mllambda code"); + if !Flags.debug then Feedback.msg_debug (Pp.str "Generated mllambda code"); let code = optimize_stk (Glet(Gconstant ("",(con,u)),code)::auxdefs) in - if !Flags.debug then Pp.msg_debug (Pp.str "Optimized mllambda code"); + if !Flags.debug then Feedback.msg_debug (Pp.str "Optimized mllambda code"); code, name | _ -> let i = push_symbol (SymbConst con) in @@ -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 |