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 26ab7773 authored by Andrei Paskevich's avatar Andrei Paskevich
Browse files

"eliminate_definition" transformation (good for match-based definitions)

parent 5b4b37e8
......@@ -134,7 +134,7 @@ TRANSFORM_CMO := simplify_recursive_definition.cmo inlining.cmo\
split_conjunction.cmo encoding_decorate.cmo\
remove_logic_definition.cmo eliminate_inductive.cmo\
compile_match.cmo eliminate_algebraic.cmo\
eliminate_definition.cmo eliminate_let.cmo
eliminate_let.cmo eliminate_definition.cmo
TRANSFORM_CMO := $(addprefix src/transform/,$(TRANSFORM_CMO))
DRIVER_CMO := call_provers.cmo dynlink_compat.cmo driver_parser.cmo\
......
......@@ -17,29 +17,146 @@
(* *)
(**************************************************************************)
open Util
open Ident
open Ty
open Term
open Decl
open Task
let add_ls acc (ls,_) = create_logic_decl [ls,None] :: acc
let unfold_t lm e = List.fold_left (fun e (v,t) -> t_let v t e) e lm
let unfold_f lm e = List.fold_left (fun e (v,t) -> f_let v t e) e lm
let add_ld acc ls ld =
let id = ls.ls_name.id_long ^ "_def" in
let pr = create_prsymbol (id_derive id ls.ls_name) in
create_prop_decl Paxiom pr (ls_defn_axiom ld) :: acc
let add_t_ax task nm ls hd e =
let vl = Svs.elements (t_freevars Svs.empty hd) in
let ax = f_forall vl [[Term hd]] (f_equ hd e) in
let id = id_derive (nm ^ "_def") ls.ls_name in
try
add_decl task (create_prop_decl Paxiom (create_prsymbol id) ax)
with
UnboundVars vs ->
Format.printf "@[%a@\n@]" Pretty.print_fmla ax; assert false
let add_ld acc (ls,ld) = match ld with
| None -> acc
| Some ld -> add_ld acc ls ld
let add_f_ax task nm ls hd e =
let vl = Svs.elements (f_freevars Svs.empty hd) in
let ax = f_forall vl [[Fmla hd]] (f_iff_simp hd e) in
let id = id_derive (nm ^ "_def") ls.ls_name in
add_decl task (create_prop_decl Paxiom (create_prsymbol id) ax)
let elim d = match d.d_node with
let uncompiled = "eliminate_algebraic: compile_match required"
let rec add_fd kn task nm ls hd lm e = match e.t_node with
| Tlet (t,b) ->
let v,e = t_open_bound b in
add_fd kn task nm ls hd ((v,t)::lm) e
| Tcase ([t],bl) ->
let t = Eliminate_let.remove_let_t (unfold_t lm t) in
begin match t.t_node with
| Tvar v ->
let mk_br (w,m) br =
let (pl,e) = t_open_branch br in
match pl with
| [{ pat_node = Papp (cs,pl) }] ->
let mk_var p = match p.pat_node with
| Pvar v -> t_var v
| _ -> failwith uncompiled
in
w, Mls.add cs (t_app cs (List.map mk_var pl) v.vs_ty, e) m
| [{ pat_node = Pwild }] ->
Some e, m
| _ -> failwith uncompiled
in
let w,m = List.fold_left mk_br (None,Mls.empty) bl in
let find cs = try Mls.find cs m with Not_found ->
let u = id_fresh "u" in
let s = ty_match Mtv.empty (of_option cs.ls_value) v.vs_ty in
let mk_v ty = t_var (create_vsymbol u (ty_inst s ty)) in
t_app cs (List.map mk_v cs.ls_args) v.vs_ty, of_option w
in
let ts = match v.vs_ty.ty_node with
| Tyapp (ts,_) -> ts
| _ -> failwith uncompiled
in
let add_cs tsk cs =
let t,e = find cs in
let lm = lm @ [v,t] in
let hd = t_subst_single v t hd in
add_fd kn tsk (nm ^ "_" ^ cs.ls_name.id_long) ls hd lm e
in
List.fold_left add_cs task (find_constructors kn ts)
| _ ->
add_t_ax task nm ls hd (unfold_t lm e)
end
| _ -> add_t_ax task nm ls hd (unfold_t lm e)
let rec add_pd kn task nm ls hd lm e = match e.f_node with
| Flet (t,b) ->
let v,e = f_open_bound b in
add_pd kn task nm ls hd ((v,t)::lm) e
| Fcase ([t],bl) ->
let t = Eliminate_let.remove_let_t (unfold_t lm t) in
begin match t.t_node with
| Tvar v ->
let mk_br (w,m) br =
let (pl,e) = f_open_branch br in
match pl with
| [{ pat_node = Papp (cs,pl) }] ->
let mk_var p = match p.pat_node with
| Pvar v -> t_var v
| _ -> failwith uncompiled
in
w, Mls.add cs (t_app cs (List.map mk_var pl) v.vs_ty, e) m
| [{ pat_node = Pwild }] ->
Some e, m
| _ -> failwith uncompiled
in
let w,m = List.fold_left mk_br (None,Mls.empty) bl in
let find cs = try Mls.find cs m with Not_found ->
let u = id_fresh "u" in
let s = ty_match Mtv.empty (of_option cs.ls_value) v.vs_ty in
let mk_v ty = t_var (create_vsymbol u (ty_inst s ty)) in
t_app cs (List.map mk_v cs.ls_args) v.vs_ty, of_option w
in
let ts = match v.vs_ty.ty_node with
| Tyapp (ts,_) -> ts
| _ -> failwith uncompiled
in
let add_cs tsk cs =
let t,e = find cs in
let lm = lm @ [v,t] in
let hd = f_subst_single v t hd in
add_pd kn tsk (nm ^ "_" ^ cs.ls_name.id_long) ls hd lm e
in
List.fold_left add_cs task (find_constructors kn ts)
| _ ->
add_f_ax task nm ls hd (unfold_f lm e)
end
| _ -> add_f_ax task nm ls hd (unfold_f lm e)
let add_ld kn task ls ld =
let vl,e = open_ls_defn ld in
let tl = List.map t_var vl in
match e with
| Term t ->
add_fd kn task ls.ls_name.id_long ls (t_app ls tl t.t_ty) [] t
| Fmla f ->
add_pd kn task ls.ls_name.id_long ls (f_app ls tl) [] f
let add_ld kn task (ls,ld) = match ld with
| None -> task
| Some ld -> add_ld kn task ls ld
let add_ls task (ls,_) = add_decl task (create_logic_decl [ls,None])
let elim t task = match t.task_decl.d_node with
| Dlogic ll ->
let dl = List.fold_left add_ls [] ll in
let dl = List.fold_left add_ld dl ll in
List.rev dl
| _ -> [d]
let task = List.fold_left add_ls task ll in
let task = List.fold_left (add_ld t.task_known) task ll in
task
| _ ->
add_decl task t.task_decl
let elim = Register.store (fun () -> Trans.decl elim None)
let elim = Register.store (fun () -> Trans.map elim None)
let () = Driver.register_transform "eliminate_definition" elim
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