Attention une mise à jour du service Gitlab va être effectuée le mardi 18 janvier (et non lundi 17 comme annoncé précédemment) entre 18h00 et 18h30. Cette mise à jour va générer une interruption du service dont nous ne maîtrisons pas complètement la durée mais qui ne devrait pas excéder quelques minutes.

Commit 22223efb authored by Martin Clochard's avatar Martin Clochard
Browse files

New transformation compute_specified.

  Variant of compute_in_goal that rewrite only the specified set of rules.
parent 2f4c8e72
......@@ -13,10 +13,14 @@ open Term
open Decl
open Task
open Theory
open Reduction_engine
let meta_rewrite = Theory.register_meta "rewrite" [Theory.MTprsymbol]
~desc:"Declares@ the@ given@ proposition@ as@ a@ rewrite@ rule."
let meta_rewrite_def = Theory.register_meta "rewrite_def" [Theory.MTlsymbol]
~desc:"Declares@ the@ definition@ of@ the@ symbol@ as@ as@ rewrite@ rule."
let meta_begin_compute_context =
Theory.register_meta "begin_compute_context" []
~desc:"Marks@ the@ position@ where@ computations@ are@ done@ by@ \
......@@ -28,22 +32,21 @@ let collect_rule_decl prs e d =
| Decl.Dlogic _ -> e
| Decl.Dprop(_, pr, t) ->
if Decl.Spr.mem pr prs then
try
Reduction_engine.add_rule t e
with Reduction_engine.NotARewriteRule msg ->
try add_rule t e
with NotARewriteRule msg ->
Warning.emit "proposition %a cannot be turned into a rewrite rule: %s"
Pretty.print_pr pr msg;
e
else e
let collect_rules env km prs t =
let collect_rules p env km prs t =
Task.task_fold
(fun e td -> match td.Theory.td_node with
| Theory.Decl d -> collect_rule_decl prs e d
| _ -> e)
(Reduction_engine.create env km) t
(create p env km) t
let normalize_goal env (prs : Decl.Spr.t) task =
let normalize_goal p env (prs : Decl.Spr.t) task =
match task with
| Some
{ task_decl =
......@@ -51,8 +54,8 @@ let normalize_goal env (prs : Decl.Spr.t) task =
task_prev = prev;
task_known = km;
} ->
let engine = collect_rules env km prs task in
let f = Reduction_engine.normalize engine f in
let engine = collect_rules p env km prs task in
let f = normalize engine f in
begin match f.t_node with
| Ttrue -> []
| _ ->
......@@ -62,11 +65,34 @@ let normalize_goal env (prs : Decl.Spr.t) task =
| _ -> assert false
let normalize_goal_transf env =
let normalize_goal_transf p env =
Trans.on_tagged_pr meta_rewrite
(fun prs -> Trans.store (normalize_goal env prs))
(fun prs -> if p.compute_defs
then Trans.store (normalize_goal p env prs)
else Trans.on_tagged_ls meta_rewrite_def
(fun lss -> let p = { p with compute_def_set = lss } in
Trans.store (normalize_goal p env prs)
))
let normalize_goal_transf_all env =
let p = { compute_defs = true;
compute_builtin = true;
compute_def_set = Term.Mls.empty;
} in
normalize_goal_transf p env
let normalize_goal_transf_few env =
let p = { compute_defs = false;
compute_builtin = false;
compute_def_set = Term.Mls.empty;
} in
normalize_goal_transf p env
let () =
Trans.register_env_transform_l "compute_in_goal" normalize_goal_transf
Trans.register_env_transform_l "compute_in_goal" normalize_goal_transf_all
~desc:"Performs@ possible@ computations@ in@ goal, including@ by@ \
declared@ rewrite@ rules"
let () =
Trans.register_env_transform_l "compute_specified" normalize_goal_transf_few
~desc:"Rewrite@ goal@ using@ specified@ rules"
......@@ -221,9 +221,16 @@ let get_builtins env =
type rule = Svs.t * term list * term
type params =
{ compute_defs : bool;
compute_builtin : bool;
compute_def_set : Term.Sls.t;
}
type engine =
{ known_map : Decl.decl Ident.Mid.t;
rules : rule list Mls.t;
params : params;
}
......@@ -561,23 +568,8 @@ and reduce_app engine st ls ty rem_cont =
let args = List.map term_of_value args in
try
let d = Ident.Mid.find ls.ls_name engine.known_map in
match d.Decl.d_node with
| Decl.Dtype _ | Decl.Dprop _ -> assert false
| Decl.Dlogic dl ->
(* regular definition *)
let d = List.assq ls dl in
let vl,e = Decl.open_ls_defn d in
let add (mt,mv) x y =
Ty.ty_match mt x.vs_ty (t_type y), Mvs.add x y mv
in
let (mt,mv) = List.fold_left2 add (Ty.Mtv.empty, Mvs.empty) vl args in
let mt = Ty.oty_match mt e.t_ty ty in
let mv,e = t_subst_types mt mv e in
{ value_stack = rem_st;
cont_stack = Keval(e,mv) :: rem_cont;
}
| Decl.Dparam _ | Decl.Dind _ ->
(* try a rewrite rule *)
let rewrite () =
(* try a rewrite rule *)
begin
try
(*
......@@ -622,7 +614,28 @@ and reduce_app engine st ls ty rem_cont =
}
with Irreducible ->
raise Not_found
end
end in
match d.Decl.d_node with
| Decl.Dtype _ | Decl.Dprop _ -> assert false
| Decl.Dlogic dl ->
(* regular definition *)
let d = List.assq ls dl in
if engine.params.compute_defs ||
Term.Sls.mem ls engine.params.compute_def_set
then begin
let vl,e = Decl.open_ls_defn d in
let add (mt,mv) x y =
Ty.ty_match mt x.vs_ty (t_type y), Mvs.add x y mv
in
let (mt,mv) = List.fold_left2 add (Ty.Mtv.empty, Mvs.empty) vl args in
let mt = Ty.oty_match mt e.t_ty ty in
let mv,e = t_subst_types mt mv e in
{ value_stack = rem_st;
cont_stack = Keval(e,mv) :: rem_cont;
}
end else rewrite ()
| Decl.Dparam _ | Decl.Dind _ ->
rewrite ()
| Decl.Ddata dl ->
(* constructor or projection *)
match args with
......@@ -821,10 +834,13 @@ let normalize ?(limit=1000) engine t0 =
(* the rewrite engine *)
let create env km =
get_builtins env;
let create p env km =
if p.compute_builtin
then get_builtins env
else Hls.clear builtins;
{ known_map = km ;
rules = Mls.empty;
params = p;
}
exception NotARewriteRule of string
......
......@@ -76,7 +76,18 @@ terms are normalized with respect to
type engine
(** abstract type for reduction engines *)
val create : Env.env -> Decl.decl Ident.Mid.t -> engine
type params = {
compute_defs : bool;
compute_builtin : bool;
compute_def_set : Term.Sls.t;
}
(** Configuration of the engine.
. [compute_defs]: if set to true, automatically compute symbols using
known definitions. Otherwise, only symbols in [compute_def_set]
will be computed.
. [compute_builtin]: if set to true, compute builtin functions. *)
val create : params -> Env.env -> Decl.decl Ident.Mid.t -> engine
(** [create env known_map] creates a reduction engine with
. builtins theories (int.Int, etc.) extracted from [env]
. known declarations from [known_map]
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment