summaryrefslogtreecommitdiff
path: root/checker/closure.ml
diff options
context:
space:
mode:
Diffstat (limited to 'checker/closure.ml')
-rw-r--r--checker/closure.ml131
1 files changed, 39 insertions, 92 deletions
diff --git a/checker/closure.ml b/checker/closure.ml
index cef1d31a..b9ae4daa 100644
--- a/checker/closure.ml
+++ b/checker/closure.ml
@@ -1,9 +1,11 @@
(************************************************************************)
-(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *)
+(* * The Coq Proof Assistant / The Coq Development Team *)
+(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *)
+(* <O___,, * (see CREDITS file for the list of authors) *)
(* \VV/ **************************************************************)
-(* // * This file is distributed under the terms of the *)
-(* * GNU Lesser General Public License Version 2.1 *)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(* * (see LICENSE file for the text of the license) *)
(************************************************************************)
open Util
@@ -49,13 +51,6 @@ let with_stats c =
end else
Lazy.force c
-type transparent_state = Id.Pred.t * Cpred.t
-let all_opaque = (Id.Pred.empty, Cpred.empty)
-let all_transparent = (Id.Pred.full, Cpred.full)
-
-let is_transparent_variable (ids, _) id = Id.Pred.mem id ids
-let is_transparent_constant (_, csts) cst = Cpred.mem cst csts
-
module type RedFlagsSig = sig
type reds
type red_kind
@@ -63,8 +58,6 @@ module type RedFlagsSig = sig
val fDELTA : red_kind
val fIOTA : red_kind
val fZETA : red_kind
- val fCONST : constant -> red_kind
- val fVAR : Id.t -> red_kind
val no_red : reds
val red_add : reds -> red_kind -> reds
val mkflags : red_kind list -> reds
@@ -80,51 +73,33 @@ module RedFlags = (struct
type reds = {
r_beta : bool;
r_delta : bool;
- r_const : transparent_state;
r_zeta : bool;
r_evar : bool;
r_iota : bool }
type red_kind = BETA | DELTA | IOTA | ZETA
- | CONST of constant | VAR of Id.t
+
let fBETA = BETA
let fDELTA = DELTA
let fIOTA = IOTA
let fZETA = ZETA
- let fCONST kn = CONST kn
- let fVAR id = VAR id
let no_red = {
r_beta = false;
r_delta = false;
- r_const = all_opaque;
r_zeta = false;
r_evar = false;
r_iota = false }
let red_add red = function
| BETA -> { red with r_beta = true }
- | DELTA -> { red with r_delta = true; r_const = all_transparent }
- | CONST kn ->
- let (l1,l2) = red.r_const in
- { red with r_const = l1, Cpred.add kn l2 }
+ | DELTA -> { red with r_delta = true}
| IOTA -> { red with r_iota = true }
| ZETA -> { red with r_zeta = true }
- | VAR id ->
- let (l1,l2) = red.r_const in
- { red with r_const = Id.Pred.add id l1, l2 }
let mkflags = List.fold_left red_add no_red
let red_set red = function
| BETA -> incr_cnt red.r_beta beta
- | CONST kn ->
- let (_,l) = red.r_const in
- let c = Cpred.mem kn l in
- incr_cnt c delta
- | VAR id -> (* En attendant d'avoir des kn pour les Var *)
- let (l,_) = red.r_const in
- let c = Id.Pred.mem id l in
- incr_cnt c delta
| ZETA -> incr_cnt red.r_zeta zeta
| IOTA -> incr_cnt red.r_iota iota
| DELTA -> (* Used for Rel/Var defined in context *)
@@ -160,22 +135,16 @@ let betaiotazeta = mkflags [fBETA;fIOTA;fZETA]
* instantiations (cbv or lazy) are.
*)
-type 'a tableKey =
- | ConstKey of 'a
- | VarKey of Id.t
- | RelKey of int
+type table_key = Constant.t puniverses tableKey
+
-type table_key = constant puniverses tableKey
+let eq_pconstant_key (c,u) (c',u') =
+ eq_constant_key c c' && Univ.Instance.equal u u'
module KeyHash =
struct
type t = table_key
- let equal k1 k2 = match k1, k2 with
- | ConstKey (c1,u1), ConstKey (c2,u2) -> Constant.UserOrd.equal c1 c2
- && Univ.Instance.equal u1 u2
- | VarKey id1, VarKey id2 -> Id.equal id1 id2
- | RelKey i1, RelKey i2 -> Int.equal i1 i2
- | (ConstKey _ | VarKey _ | RelKey _), _ -> false
+ let equal = Names.eq_table_key eq_pconstant_key
open Hashset.Combine
@@ -226,8 +195,6 @@ let defined_rels flags env =
let mind_equiv_infos info = mind_equiv info.i_env
-let eq_table_key = KeyHash.equal
-
let create mk_cl flgs env =
{ i_flags = flgs;
i_repr = mk_cl;
@@ -276,14 +243,13 @@ and fterm =
| FInd of pinductive
| FConstruct of pconstructor
| FApp of fconstr * fconstr array
- | FProj of projection * fconstr
+ | FProj of Projection.t * fconstr
| FFix of fixpoint * fconstr subs
| FCoFix of cofixpoint * fconstr subs
- | FCase of case_info * fconstr * fconstr * fconstr array
| FCaseT of case_info * constr * fconstr * constr array * fconstr subs (* predicate and branches are closures *)
- | FLambda of int * (name * constr) list * constr * fconstr subs
- | FProd of name * fconstr * fconstr
- | FLetIn of name * fconstr * fconstr * constr * fconstr subs
+ | FLambda of int * (Name.t * constr) list * constr * fconstr subs
+ | FProd of Name.t * fconstr * fconstr
+ | FLetIn of Name.t * fconstr * fconstr * constr * fconstr subs
| FEvar of existential_key * fconstr array (* why diff from kernel/closure? *)
| FLIFT of int * fconstr
| FCLOS of constr * fconstr subs
@@ -306,9 +272,8 @@ let update v1 (no,t) =
type stack_member =
| Zapp of fconstr array
- | Zcase of case_info * fconstr * fconstr array
| ZcaseT of case_info * constr * constr array * fconstr subs
- | Zproj of int * int * projection
+ | Zproj of int * int * Projection.t
| Zfix of fconstr * stack
| Zshift of int
| Zupdate of fconstr
@@ -328,6 +293,12 @@ let zshift n s =
| (_,Zshift(k)::s) -> Zshift(n+k)::s
| _ -> Zshift(n)::s
+let rec stack_args_size = function
+ | Zapp v :: s -> Array.length v + stack_args_size s
+ | Zshift(_)::s -> stack_args_size s
+ | Zupdate(_)::s -> stack_args_size s
+ | _ -> 0
+
(* Lifting. Preserves sharing (useful only for cell with norm=Red).
lft_fconstr always create a new cell, while lift_fconstr avoids it
when the lift is 0. *)
@@ -450,13 +421,10 @@ let rec to_constr constr_fun lfts v =
| FFlex (ConstKey op) -> Const op
| FInd op -> Ind op
| FConstruct op -> Construct op
- | FCase (ci,p,c,ve) ->
- Case (ci, constr_fun lfts p,
- constr_fun lfts c,
- Array.map (constr_fun lfts) ve)
- | FCaseT (ci,p,c,ve,e) -> (* TODO: enable sharing, cf FCLOS below ? *)
- to_constr constr_fun lfts
- {norm=Red;term=FCase(ci,mk_clos2 e p,c,mk_clos_vect e ve)}
+ | FCaseT (ci,p,c,ve,e) ->
+ let fp = mk_clos2 e p in
+ let fve = mk_clos_vect e ve in
+ Case (ci, constr_fun lfts fp, constr_fun lfts c, Array.map (constr_fun lfts) fve)
| FFix ((op,(lna,tys,bds)),e) ->
let n = Array.length bds in
let ftys = Array.map (mk_clos e) tys in
@@ -526,9 +494,6 @@ let rec zip m stk =
match stk with
| [] -> m
| Zapp args :: s -> zip {norm=neutr m.norm; term=FApp(m, args)} s
- | Zcase(ci,p,br)::s ->
- let t = FCase(ci, p, m, br) in
- zip {norm=neutr m.norm; term=t} s
| ZcaseT(ci,p,br,e)::s ->
let t = FCaseT(ci, p, m, br, e) in
zip {norm=neutr m.norm; term=t} s
@@ -610,7 +575,7 @@ let rec get_args n tys f e stk =
(* Eta expansion: add a reference to implicit surrounding lambda at end of stack *)
let rec eta_expand_stack = function
- | (Zapp _ | Zfix _ | Zcase _ | ZcaseT _ | Zproj _
+ | (Zapp _ | Zfix _ | ZcaseT _ | Zproj _
| Zshift _ | Zupdate _ as e) :: s ->
e :: eta_expand_stack s
| [] ->
@@ -651,22 +616,6 @@ let drop_parameters depth n argstk =
(** Projections and eta expansion *)
-let rec get_parameters depth n argstk =
- match argstk with
- Zapp args::s ->
- let q = Array.length args in
- if n > q then Array.append args (get_parameters depth (n-q) s)
- else if Int.equal n q then [||]
- else Array.sub args 0 n
- | Zshift(k)::s ->
- get_parameters (depth-k) n s
- | [] -> (* we know that n < stack_args_size(argstk) (if well-typed term) *)
- if Int.equal n 0 then [||]
- else raise Not_found (* Trying to eta-expand a partial application..., should do
- eta expansion first? *)
- | _ -> assert false
- (* strip_update_shift_app only produces Zapp and Zshift items *)
-
let eta_expand_ind_stack env ind m s (f, s') =
let mib = lookup_mind (fst ind) env in
match mib.mind_record with
@@ -718,6 +667,9 @@ let contract_fix_vect fix =
in
(subs_cons(Array.init nfix make_body, env), thisbody)
+let unfold_projection env p =
+ let pb = lookup_projection p env in
+ Zproj (pb.proj_npars, pb.proj_arg, p)
(*********************************************************************)
(* A machine that inspects the head of a term until it finds an
@@ -730,7 +682,6 @@ let rec knh info m stk =
| FCLOS(t,e) -> knht info e t (zupdate m stk)
| FLOCKED -> assert false
| FApp(a,b) -> knh info a (append_stack b (zupdate m stk))
- | FCase(ci,p,t,br) -> knh info t (Zcase(ci,p,br)::zupdate m stk)
| FCaseT(ci,p,t,br,env) -> knh info t (ZcaseT(ci,p,br,env)::zupdate m stk)
| FFix(((ri,n),(_,_,_)),_) ->
(match get_nth_arg m ri.(n) stk with
@@ -739,10 +690,9 @@ let rec knh info m stk =
| FCast(t,_,_) -> knh info t stk
| FProj (p,c) ->
- if red_set info.i_flags (fCONST (Projection.constant p)) then
- (let pb = lookup_projection p (info.i_env) in
- knh info c (Zproj (pb.proj_npars, pb.proj_arg, p)
- :: zupdate m stk))
+ if red_set info.i_flags fDELTA then
+ let s = unfold_projection info.i_env p in
+ knh info c (s :: zupdate m stk)
else (m,stk)
(* cases where knh stops *)
@@ -774,11 +724,11 @@ let rec knr info m stk =
(match get_args n tys f e stk with
Inl e', s -> knit info e' f s
| Inr lam, s -> (lam,s))
- | FFlex(ConstKey kn) when red_set info.i_flags (fCONST (fst kn)) ->
+ | FFlex(ConstKey kn) when red_set info.i_flags fDELTA ->
(match ref_value_cache info (ConstKey kn) with
Some v -> kni info v stk
| None -> (set_norm m; (m,stk)))
- | FFlex(VarKey id) when red_set info.i_flags (fVAR id) ->
+ | FFlex(VarKey id) when red_set info.i_flags fDELTA ->
(match ref_value_cache info (VarKey id) with
Some v -> kni info v stk
| None -> (set_norm m; (m,stk)))
@@ -788,10 +738,6 @@ let rec knr info m stk =
| None -> (set_norm m; (m,stk)))
| FConstruct((ind,c),u) when red_set info.i_flags fIOTA ->
(match strip_update_shift_app m stk with
- (depth, args, Zcase(ci,_,br)::s) ->
- assert (ci.ci_npar>=0);
- let rargs = drop_parameters depth ci.ci_npar args in
- kni info br.(c-1) (rargs@s)
| (depth, args, ZcaseT(ci,_,br,env)::s) ->
assert (ci.ci_npar>=0);
let rargs = drop_parameters depth ci.ci_npar args in
@@ -808,7 +754,7 @@ let rec knr info m stk =
| (_,args,s) -> (m,args@s))
| FCoFix _ when red_set info.i_flags fIOTA ->
(match strip_update_shift_app m stk with
- (_, args, (((Zcase _|ZcaseT _)::_) as stk')) ->
+ (_, args, (((ZcaseT _|Zproj _)::_) as stk')) ->
let (fxe,fxbd) = contract_fix_vect m.term in
knit info fxe fxbd (args@stk')
| (_,args,s) -> (m,args@s))
@@ -845,6 +791,7 @@ type clos_infos = fconstr infos
let infos_env x = x.i_env
let infos_flags x = x.i_flags
+let oracle_of_infos x = x.i_env.env_conv_oracle
let create_clos_infos flgs env =
create (fun _ -> inject) flgs env
generated by cgit v1.2.3 (git 2.39.1) at 2024-05-07 06:54:57 +0000