Skip to content

GitLab

Commit 72a36bd8 authored by Jean-Christophe Filliâtre's avatar Jean-Christophe Filliâtre
Browse files

modules: huge refactoring of programs types, in preparation for mutable types

parent 2d519b26
Expand all Hide whitespace changes
Inline Side-by-side
Makefile.in
View file @ 72a36bd8
......@@ -281,7 +281,7 @@ install_no_local::
PGMGENERATED = src/programs/pgm_parser.mli src/programs/pgm_parser.ml \
src/programs/pgm_lexer.ml
PGM_FILES = pgm_ttree pgm_ptree pgm_parser pgm_lexer pgm_effect \
PGM_FILES = pgm_ttree pgm_ptree pgm_parser pgm_lexer \
pgm_types pgm_module pgm_wp pgm_env pgm_typing pgm_main
PGMMODULES = $(addprefix src/programs/, $(PGM_FILES))
......
src/programs/pgm_fastwp.ml
View file @ 72a36bd8
......@@ -29,7 +29,7 @@ open Theory
open Pgm_ttree
open Pgm_typing
module E = Pgm_effect
module E = Pgm_types.E
module State : sig
type t
......
src/programs/pgm_module.ml
View file @ 72a36bd8
......@@ -6,6 +6,7 @@ open Theory
open Term
open Pgm_types
open Pgm_types.T
open Pgm_ttree
module Mnm = Mstr
......@@ -34,11 +35,9 @@ let ns_replace eq chk x vo vn =
let ns_union eq chk =
Mnm.union (fun x vn vo -> Some (ns_replace eq chk x vo vn))
let pr_equal p1 p2 = ls_equal p1.p_ls p2.p_ls
let rec merge_ns chk ns1 ns2 =
let fusion _ ns1 ns2 = Some (merge_ns chk ns1 ns2) in
{ ns_pr = ns_union pr_equal chk ns1.ns_pr ns2.ns_pr;
{ ns_pr = ns_union p_equal chk ns1.ns_pr ns2.ns_pr;
ns_ex = ns_union ls_equal chk ns1.ns_ex ns2.ns_ex;
ns_mt = ns_union mt_equal chk ns1.ns_mt ns2.ns_mt;
ns_ns = Mnm.union fusion ns1.ns_ns ns2.ns_ns; }
......@@ -51,7 +50,7 @@ let ns_add eq chk x v m = Mnm.change x (function
| None -> Some v
| Some vo -> Some (ns_replace eq chk x vo v)) m
let pr_add = ns_add pr_equal
let pr_add = ns_add p_equal
let ex_add = ns_add ls_equal
let mt_add = ns_add mt_equal
......@@ -131,7 +130,7 @@ let add_symbol add id v uc =
| _ -> assert false
let add_psymbol ps uc =
add_symbol add_pr ps.p_ls.ls_name ps uc
add_symbol add_pr ps.p_name ps uc
let add_esymbol ls uc =
add_symbol add_ex ls.ls_name ls uc
......
src/programs/pgm_module.mli
View file @ 72a36bd8
......@@ -3,6 +3,7 @@ open Why
open Ident
open Term
open Pgm_types
open Pgm_types.T
module Mnm : Map.S with type key = string
......
src/programs/pgm_ttree.ml
View file @ 72a36bd8
......@@ -18,6 +18,8 @@
(**************************************************************************)
open Why
open Pgm_types
open Pgm_types.T
type loc = Loc.position
......@@ -36,20 +38,22 @@ type for_direction = Pgm_ptree.for_direction
type dreference =
| DRlocal of string
| DRglobal of Term.lsymbol
| DRglobal of psymbol
type deffect = {
de_reads : dreference list;
de_writes : dreference list;
de_raises : Term.lsymbol list;
de_raises : esymbol list;
}
type dpre = Denv.dfmla
type dpost = Denv.dfmla * (Term.lsymbol * Denv.dfmla) list
type dpost_fmla = Denv.dty * Denv.dfmla
type dexn_post_fmla = Denv.dty option * Denv.dfmla
type dpost = dpost_fmla * (Term.lsymbol * dexn_post_fmla) list
type dtype_v =
| DTpure of Denv.dty
| DTpure of Denv.dty
| DTarrow of dbinder list * dtype_c
and dtype_c =
......@@ -58,7 +62,7 @@ and dtype_c =
dc_pre : dpre;
dc_post : dpost; }
and dbinder = ident * dtype_v
and dbinder = ident * Denv.dty * dtype_v
type dvariant = Denv.dterm * Term.lsymbol
......@@ -76,8 +80,8 @@ type dexpr = {
and dexpr_desc =
| DEconstant of constant
| DElocal of string * dtype_v
| DEglobal of Term.lsymbol * dtype_v
| DElocal of string * Denv.dty
| DEglobal of psymbol * dtype_v
| DElogic of Term.lsymbol
| DEapply of dexpr * dexpr
| DEfun of dbinder list * dtriple
......@@ -90,8 +94,8 @@ and dexpr_desc =
| DElazy of lazy_op * dexpr * dexpr
| DEmatch of dexpr * (Denv.dpattern * dexpr) list
| DEabsurd
| DEraise of Term.lsymbol * dexpr option
| DEtry of dexpr * (Term.lsymbol * string option * dexpr) list
| DEraise of esymbol * dexpr option
| DEtry of dexpr * (esymbol * string option * dexpr) list
| DEfor of ident * dexpr * for_direction * dexpr * Denv.dfmla option * dexpr
| DEassert of assertion_kind * Denv.dfmla
......@@ -107,19 +111,39 @@ and dtriple = dpre * dexpr * dpost
type variant = Term.term * Term.lsymbol
type rec_variant = Term.vsymbol * Term.term * Term.lsymbol
type reference = R.t
type reference = Pgm_effect.reference
type pre = T.pre
type pre = Pgm_types.pre
type post = T.post
type post = Pgm_types.post
type ivsymbol = {
i_name : Ident.preid;
i_ty : Ty.ty;
i_vs : Term.vsymbol;
}
type ireference =
| IRlocal of ivsymbol
| IRglobal of psymbol
type ieffect = {
ie_reads : ireference list;
ie_writes : ireference list;
ie_raises : esymbol list;
}
type type_v = Pgm_types.type_v
type itype_v =
| ITpure of Ty.ty
| ITarrow of ibinder list * itype_c
type type_c = Pgm_types.type_c
and itype_c =
{ ic_result_type : itype_v;
ic_effect : ieffect;
ic_pre : pre;
ic_post : post; }
type binder = Pgm_types.binder
and ibinder = ivsymbol * itype_v
type loop_annotation = {
loop_invariant : Term.fmla option;
......@@ -128,6 +152,20 @@ type loop_annotation = {
type label = Term.vsymbol
type irec_variant = ivsymbol * Term.term * Term.lsymbol
type ipattern = {
ipat_pat : Term.pattern;
ipat_node : ipat_node;
}
and ipat_node =
| IPwild
| IPvar of ivsymbol
| IPapp of Term.lsymbol * ipattern list
| IPor of ipattern * ipattern
| IPas of ipattern * ivsymbol
type iexpr = {
iexpr_desc : iexpr_desc;
iexpr_type : Ty.ty;
......@@ -136,29 +174,29 @@ type iexpr = {
and iexpr_desc =
| IElogic of Term.term
| IElocal of Term.vsymbol * type_v
| IEglobal of Term.lsymbol * type_v
| IEapply of iexpr * Term.vsymbol
| IEapply_ref of iexpr * reference
| IEfun of binder list * itriple
| IElet of Term.vsymbol * iexpr * iexpr
| IElocal of ivsymbol
| IEglobal of psymbol
| IEapply of iexpr * ivsymbol
(* | IEapply_ref of iexpr * reference *)
| IEfun of ibinder list * itriple
| IElet of ivsymbol * iexpr * iexpr
| IEletrec of irecfun list * iexpr
| IEif of iexpr * iexpr * iexpr
| IEloop of loop_annotation * iexpr
| IElazy of lazy_op * iexpr * iexpr
| IEmatch of Term.vsymbol * (Term.pattern * iexpr) list
| IEmatch of ivsymbol * (ipattern * iexpr) list
| IEabsurd
| IEraise of Term.lsymbol * iexpr option
| IEtry of iexpr * (Term.lsymbol * Term.vsymbol option * iexpr) list
| IEfor of Term.vsymbol * Term.vsymbol * for_direction * Term.vsymbol *
| IEraise of esymbol * iexpr option
| IEtry of iexpr * (esymbol * ivsymbol option * iexpr) list
| IEfor of ivsymbol * ivsymbol * for_direction * ivsymbol *
Term.fmla option * iexpr
| IEassert of assertion_kind * Term.fmla
| IElabel of label * iexpr
| IEany of type_c
| IEany of itype_c
and irecfun = Term.vsymbol * binder list * rec_variant option * itriple
and irecfun = ivsymbol * ibinder list * irec_variant option * itriple
and itriple = pre * iexpr * post
......@@ -166,43 +204,57 @@ and itriple = pre * iexpr * post
(*****************************************************************************)
(* phase 3: effect inference *)
type rec_variant = pvsymbol * Term.term * Term.lsymbol
type pattern = {
ppat_pat : Term.pattern;
ppat_node : ppat_node;
}
and ppat_node =
| Pwild
| Pvar of pvsymbol
| Papp of Term.lsymbol * pattern list
| Por of pattern * pattern
| Pas of pattern * pvsymbol
type expr = {
expr_desc : expr_desc;
expr_type : Ty.ty;
expr_type_v: type_v;
expr_effect: Pgm_effect.t;
expr_effect: E.t;
expr_loc : loc;
}
and expr_desc =
| Elogic of Term.term
| Elocal of Term.vsymbol
| Eglobal of Term.lsymbol
| Efun of binder list * triple
| Elet of Term.vsymbol * expr * expr
| Elocal of pvsymbol
| Eglobal of psymbol
| Efun of pvsymbol list * triple
| Elet of pvsymbol * expr * expr
| Eletrec of recfun list * expr
| Eif of expr * expr * expr
| Eloop of loop_annotation * expr
| Ematch of Term.vsymbol * (Term.pattern * expr) list
| Ematch of pvsymbol * (pattern * expr) list
| Eabsurd
| Eraise of Term.lsymbol * expr option
| Etry of expr * (Term.lsymbol * Term.vsymbol option * expr) list
| Efor of Term.vsymbol * Term.vsymbol * for_direction * Term.vsymbol *
| Eraise of esymbol * expr option
| Etry of expr * (esymbol * pvsymbol option * expr) list
| Efor of pvsymbol * pvsymbol * for_direction * pvsymbol *
Term.fmla option * expr
| Eassert of assertion_kind * Term.fmla
| Elabel of label * expr
| Eany of type_c
and recfun = Term.vsymbol * binder list * rec_variant option * triple
and recfun = pvsymbol * pvsymbol list * rec_variant option * triple
and triple = pre * expr * post
type decl =
| Dlet of Pgm_types.psymbol * expr
| Dletrec of (Pgm_types.psymbol * recfun) list
| Dparam of Pgm_types.psymbol * type_v
| Dlet of T.psymbol * expr
| Dletrec of (T.psymbol * recfun) list
| Dparam of T.psymbol * type_v
type file = decl list
......
src/programs/pgm_types.ml
View file @ 72a36bd8
......@@ -6,7 +6,6 @@ open Ty
open Theory
open Term
open Decl
module E = Pgm_effect
(* mutable types *)
......@@ -54,228 +53,490 @@ let model_type ty = match ty.ty_node with
(* types *)
type effect = Pgm_effect.t
type reference = Pgm_effect.reference
type pre = Term.fmla
type post_fmla = Term.vsymbol (* result *) * Term.fmla
type exn_post_fmla = Term.vsymbol (* result *) option * Term.fmla
type post = post_fmla * (Term.lsymbol * exn_post_fmla) list
type type_v =
| Tpure of Ty.ty
| Tarrow of binder list * type_c
and type_c =
{ c_result_type : type_v;
c_effect : effect;
c_pre : pre;
c_post : post; }
and binder = Term.vsymbol * type_v
(* purify: turns program types into logic types *)
let ts_arrow =
let v = List.map (fun s -> create_tvsymbol (Ident.id_fresh s)) ["a"; "b"] in
Ty.create_tysymbol (Ident.id_fresh "arrow") v None
let make_arrow_type tyl ty =
let arrow ty1 ty2 = Ty.ty_app ts_arrow [ty1; ty2] in
List.fold_right arrow tyl ty
let rec uncurry_type ?(logic=false) = function
| Tpure ty when not logic ->
[], ty
| Tpure ty ->
[], begin try model_type ty with NotMutable -> ty end
| Tarrow (bl, c) ->
let tyl1 = List.map (fun (v,_) -> v.vs_ty) bl in
let tyl2, ty = uncurry_type ~logic c.c_result_type in
tyl1 @ tyl2, ty (* TODO: improve efficiency? *)
let purify ?(logic=false) v =
let tyl, ty = uncurry_type ~logic v in
make_arrow_type tyl ty
(* symbols *)
type psymbol = {
p_ls : lsymbol;
p_tv : type_v;
}
module Sexn = Term.Sls
let create_psymbol id v =
let tyl, ty = uncurry_type v in
let ls = create_lsymbol id tyl (Some ty) in
{ p_ls = ls; p_tv = v }
type esymbol = lsymbol
(* misc. functions *)
let v_result ty = create_vsymbol (id_fresh "result") ty
let exn_v_result ls = match ls.ls_args with
| [] -> None
| [ty] -> Some (v_result ty)
| _ -> assert false
let post_map f ((v, q), ql) =
(v, f q), List.map (fun (e,(v,q)) -> e, (v, f q)) ql
let type_c_of_type_v = function
| Tarrow ([], c) ->
c
| v ->
let ty = purify v in
{ c_result_type = v;
c_effect = Pgm_effect.empty;
c_pre = f_true;
c_post = (v_result ty, f_true), []; }
let rec subst_var ts s vs =
let ty' = ty_inst ts vs.vs_ty in
if ty_equal ty' vs.vs_ty then
s, vs
else
let vs' = create_vsymbol (id_clone vs.vs_name) ty' in
Mvs.add vs (t_var vs') s, vs'
and subst_post ts s ((v, q), ql) =
let vq = let s, v = subst_var ts s v in v, f_ty_subst ts s q in
let handler (e, (v, q)) = match v with
| None -> e, (v, f_ty_subst ts s q)
| Some v -> let s, v = subst_var ts s v in e, (Some v, f_ty_subst ts s q)
in
vq, List.map handler ql
let rec subst_type_c ef ts s c =
{ c_result_type = subst_type_v ef ts s c.c_result_type;
c_effect = E.subst ef c.c_effect;
c_pre = f_ty_subst ts s c.c_pre;
c_post = subst_post ts s c.c_post; }
and subst_type_v ef ts s = function
| Tpure ty ->
Tpure (ty_inst ts ty)
| Tarrow (bl, c) ->
let s, bl = Util.map_fold_left (binder ef ts) s bl in
Tarrow (bl, subst_type_c ef ts s c)
and binder ef ts s (vs, v) =
let v = subst_type_v ef ts s v in
let s, vs = subst_var ts s vs in
s, (vs, v)
let tpure ty = Tpure ty
let tarrow bl c = match bl with
| [] ->
invalid_arg "tarrow"
| _ ->
let rename (e, s) (vs, v) =
let vs' = create_vsymbol (id_clone vs.vs_name) vs.vs_ty in
let v' = subst_type_v e Mtv.empty s v in
let e' = Mvs.add vs (E.Rlocal vs') e in
let s' = Mvs.add vs (t_var vs') s in
(e', s'), (vs', v')
in
let (e, s), bl' = Util.map_fold_left rename (Mvs.empty, Mvs.empty) bl in
Tarrow (bl', subst_type_c e Mtv.empty s c)
let subst1 vs1 t2 = Mvs.add vs1 t2 Mvs.empty
let apply_type_v v vs = match v with
| Tarrow ((x, tyx) :: bl, c) ->
let ts = ty_match Mtv.empty (purify tyx) vs.vs_ty in
let c = type_c_of_type_v (Tarrow (bl, c)) in
subst_type_c Mvs.empty ts (subst1 x (t_var vs)) c
| Tarrow ([], _) | Tpure _ ->
assert false
let apply_type_v_ref v r = match r, v with
| E.Rlocal vs as r, Tarrow ((x, tyx) :: bl, c) ->
let ts = ty_match Mtv.empty (purify tyx) vs.vs_ty in
let c = type_c_of_type_v (Tarrow (bl, c)) in
let ef = Mvs.add x r Mvs.empty in
subst_type_c ef ts (subst1 x (t_var vs)) c
| E.Rglobal ls as r, Tarrow ((x, tyx) :: bl, c) ->
let ty = match ls.ls_value with None -> assert false | Some ty -> ty in
let ts = ty_match Mtv.empty (purify tyx) ty in
let c = type_c_of_type_v (Tarrow (bl, c)) in
let ef = Mvs.add x r Mvs.empty in
subst_type_c ef ts (subst1 x (t_app ls [] ty)) c
| _ ->
assert false
let occur_formula r f = match r with
| E.Rlocal vs -> f_occurs_single vs f
| E.Rglobal ls -> f_s_any (fun _ -> false) (ls_equal ls) f
let rec occur_type_v r = function
| Tpure _ ->
false
| Tarrow (bl, c) ->
occur_arrow r bl c
and occur_arrow r bl c = match bl with
| [] ->
occur_type_c r c
| (vs, v) :: bl ->
occur_type_v r v ||
not (E.ref_equal r (E.Rlocal vs)) && occur_arrow r bl c
and occur_type_c r c =
occur_type_v r c.c_result_type ||
occur_formula r c.c_pre ||
E.occur r c.c_effect ||
occur_post r c.c_post
and occur_post r ((_, q), ql) =
occur_formula r q ||
List.exists (fun (_, (_, qe)) -> occur_formula r qe) ql
let rec eq_type_v v1 v2 = match v1, v2 with
| Tpure ty1, Tpure ty2 ->
ty_equal ty1 ty2
| Tarrow _, Tarrow _ ->
false (* TODO? *)
| _ ->
assert false
(* pretty-printers *)
open Pp
open Format
open Pretty
let print_post fmt ((_,q), el) =
let print_exn_post fmt (l,(_,q)) =
fprintf fmt "| %a -> {%a}" print_ls l print_fmla q
in
fprintf fmt "{%a} %a" print_fmla q (print_list space print_exn_post) el
module rec T : sig
let rec print_type_v fmt = function
| Tpure ty ->
print_ty fmt ty
| Tarrow (bl, c) ->
fprintf fmt "@[<hov 2>%a ->@ %a@]"
(print_list arrow print_binder) bl print_type_c c
type pre = Term.fmla
and print_type_c fmt c =
fprintf fmt "@[{%a}@ %a%a@ %a@]" print_fmla c.c_pre
print_type_v c.c_result_type Pgm_effect.print c.c_effect
print_post c.c_post
type post_fmla = Term.vsymbol (* result *) * Term.fmla
type exn_post_fmla = Term.vsymbol (* result *) option * Term.fmla
type esymbol = lsymbol
and print_binder fmt (x, v) =
fprintf fmt "(%a:%a)" print_vs x print_type_v v
type post = post_fmla * (esymbol * exn_post_fmla) list
(* let apply_type_v env v vs = *)
(* eprintf "apply_type_v: v=%a vs=%a@." print_type_v v print_vs vs; *)
(* apply_type_v env v vs *)
type type_v = private
| Tpure of ty
| Tarrow of pvsymbol list * type_c
and type_c = {
c_result_type : type_v;
c_effect : E.t;
c_pre : pre;
c_post : post;
}
and pvsymbol = private {
pv_name : ident;
pv_tv : type_v;
pv_ty : ty; (* as a logic type, for typing purposes only *)
pv_vs : vsymbol; (* for use in the logic *)
}
val tpure : ty -> type_v
val tarrow : pvsymbol list -> type_c -> type_v
val create_pvsymbol : preid -> ?vs:vsymbol -> type_v -> pvsymbol
val compare_pvsymbol : pvsymbol -> pvsymbol -> int
(* program symbols *)
type psymbol = private {
p_name : ident;
p_tv : type_v;
p_ty : ty; (* as a logic type, for typing purposes only *)
p_ls : lsymbol; (* for use in the logic *)
}
val create_psymbol : preid -> type_v -> psymbol
val p_equal : psymbol -> psymbol -> bool
(* program types -> logic types *)
val purify : ty -> ty
val purify_type_v : ?logic:bool -> type_v -> ty
(** when [logic] is [true], mutable types are turned into their models *)
(* operations on program types *)
val apply_type_v_var : type_v -> pvsymbol -> type_c
val apply_type_v_sym : type_v -> psymbol -> type_c