Commit bb6734a1 authored by Andrei Paskevich's avatar Andrei Paskevich

track dangerous applications of equality

In programs, but also in pure theories, it is not safe to compare
arbitrary types. For example, if we have a record with ghost fields,
a comparison may produce different results before and after ghost
code elimination. Even for pure types like 'map' or 'set', it is
unlikely that the result of logical equality will be the same as
the result of OCaml structural equality on the implemented type.

This commit makes the first step towards fixing this issue.
We proceed in the following way:

1. Every lsymbol (pure function or predicate symbol) carries
   a subset of type variables of its signature, called "opaque
   type variables". By marking a type variable 'a opaque in an
   lsymbol's signature, the user guarantees that this lsymbol
   can be implemented without ever comparing values of type 'a.
   In other words, this is a promise not to break into a type
   variable.

   The corresponding syntax is: "predicate safe (x y : ~'a)".

   All type variables in undefined symbols are non-opaque,
   unless annotated otherwise. Non-opaque is the default
   to keep the change conservative.

   Opacity of type variables in defined symbols is inferred
   from the definition. If the definition violates a given
   opacity annotation, an exception is raised. Notice that
   we only check definitions in _theory_ declarations. One
   can define an lsymbol in a _task_ in a way that violates
   opacity. We cannot forbid it, because various elimination
   transformations would replace safe operations (such as
   matching) with equalities. This is not a problem, since in
   the pure logical realm of provers opacity is not required
   One exception would be Coq, whose transformation chain must
   never perform such operations.

   All type variables in inductive predicates are non-opaque.
   Indeed, we can redefine equality via an inductive predicate.
   [TODO: find safe forms of inductive definitions and implement
   more reasonable restrictions.]

   All type variables in constructors and field symbols are opaque.

   It is forbidden to instantiate an opacity-preserving symbol
   with an opacity-breaking one in a clone substitution.

2. Similar type variable tracking is implemented for program symbols.
   Type variables in the signature of a "val" are non-opaque unless
   annotated otherwise. Opacity of type variables in defined symbols
   is inferred from the definition, and an exception is raised, if
   a given annotation is violated.

   The internal mechanism of tracking is different: the "eff_compar"
   field in effects contains the type variables that occur under
   equality or any other opacity-breaking operation. In this respect,
   our API is inconsistent between lsymbols and psymbols: the former
   asks for the opaque tvsymbols, the latter requires us to fill the
   spec with "comparison effects" for the non-opaque ones. [TODO:
   add the "~opaque" argument to create_psymbol and make the WhyML
   core fill the effect under the hood.]

   Every time an lsymbol or a psymbol is applied in a program,
   we check the substitution into its signature's type variables.
   If a non-opaque type variable is instantiated with a program type,
   an exception is raised. [TODO: be more precise and reject only
   types with ghost and model components - being mutable, private,
   or carrying an invariant doesn't conflict with equality.]

   Notice that we do not allow to compare program types even in
   the ghost code. This is not needed if we only consider the
   problems of the code extraction, but _might_ be necessary,
   if we also want to protect Coq realisations (see below).

This commit fixes the immediate problem of breaking the ghost
guarantees when equality or some other opacity-breaking lsymbol
is applied in a program to a type with ghost or "model" parts.

This leaves the problem of code extraction for programs that
compare complex types such as maps or sets (Coq driver is
affected by this, too, I guess). The next step is to provide
annotations for problematic type constructors. A declaration
"type ~map 'a 'b" would mean "logical equality on this type
is likely to be different from the structural equality on any
implementation of this type - therefore do not apply equality
to it: neither in programs (because this can't be implemented),
nor in pure functions (because they are extracted, too, and
because this can't be realized with Leibniz equality in Coq)."
[TODO: discuss and implement.]

[TODO: mb choose better term for "opaque" and notation for ~'a.]
parent 0b96283e
module T1
predicate my_eq (x : ~'a) (y : 'a) = my_eq1 x y
with my_eq1 (x : 'a) (y : 'a) = my_eq2 x y
with my_eq2 (x : 'a) (y : 'a) = x = y
end
module T0
predicate eq (x y : ~'a)
end
module T1
predicate my_eq (x : 'a) (y : 'a) = my_eq1 x y
with my_eq1 (x : 'a) (y : 'a) = my_eq2 x y
with my_eq2 (x : 'a) (y : 'a) = x = y
clone T0 with predicate eq = my_eq
end
module T1
predicate my_eq (x : 'a) (y : 'a) = my_eq1 x y
with my_eq1 (x : 'a) (y : 'a) = my_eq2 x y
with my_eq2 (x : 'a) (y : 'a) = x = y
type t1 = { ghost f1 : int }
type t2 = Shell t1
let test1 (x: int) =
let r1 = Shell { f1 = x } in
my_eq r1 r1
end
module T1
predicate my_eq (x : 'a) (y : 'a) = my_eq1 x y
with my_eq1 (x : 'a) (y : 'a) = my_eq2 x y
with my_eq2 (x : 'a) (y : 'a) = x = y
let my_p_eq (x y : 'b) = my_eq x y
type t1 model { f1 : int }
type t2 = Shell t1
let test1 (x: t2) = my_p_eq x x
end
module T1
predicate my_eq (x : 'a) (y : 'a) = my_eq1 x y
with my_eq1 (x : 'a) (y : 'a) = my_eq2 x y
with my_eq2 (x : 'a) (y : 'a) = x = y
let my_p_eq (x y : ~'a) = my_eq x y
end
......@@ -45,6 +45,7 @@ type lsymbol = {
ls_name : ident;
ls_args : ty list;
ls_value : ty option;
ls_opaque : Stv.t;
}
module Lsym = MakeMSHW (struct
......@@ -61,14 +62,21 @@ let ls_equal : lsymbol -> lsymbol -> bool = (==)
let ls_hash ls = id_hash ls.ls_name
let create_lsymbol name args value = {
let check_opaque opaque args value =
if Stv.is_empty opaque then opaque else
let diff s ty = ty_v_fold (fun s tv -> Stv.remove tv s) s ty in
let s = List.fold_left diff (Opt.fold diff opaque value) args in
if Stv.is_empty s then opaque else invalid_arg "Term.create_lsymbol"
let create_lsymbol ?(opaque=Stv.empty) name args value = {
ls_name = id_register name;
ls_args = args;
ls_value = value;
ls_opaque = check_opaque opaque args value;
}
let create_fsymbol nm al vl = create_lsymbol nm al (Some vl)
let create_psymbol nm al = create_lsymbol nm al (None)
let create_fsymbol ?opaque nm al vl = create_lsymbol ?opaque nm al (Some vl)
let create_psymbol ?opaque nm al = create_lsymbol ?opaque nm al (None)
let ls_ty_freevars ls =
let acc = oty_freevars Stv.empty ls.ls_value in
......@@ -795,9 +803,11 @@ let fs_tuple_ids = Hid.create 17
let fs_tuple = Hint.memo 17 (fun n ->
let ts = ts_tuple n in
let opaque = Stv.of_list ts.ts_args in
let tl = List.map ty_var ts.ts_args in
let ty = ty_app ts tl in
let fs = create_fsymbol (id_fresh ("Tuple" ^ string_of_int n)) tl ty in
let id = id_fresh ("Tuple" ^ string_of_int n) in
let fs = create_fsymbol ~opaque id tl ty in
Hid.add fs_tuple_ids fs.ls_name n;
fs)
......
......@@ -38,6 +38,7 @@ type lsymbol = private {
ls_name : ident;
ls_args : ty list;
ls_value : ty option;
ls_opaque : Stv.t;
}
module Mls : Extmap.S with type key = lsymbol
......@@ -48,9 +49,9 @@ module Wls : Weakhtbl.S with type key = lsymbol
val ls_equal : lsymbol -> lsymbol -> bool
val ls_hash : lsymbol -> int
val create_lsymbol : preid -> ty list -> ty option -> lsymbol
val create_fsymbol : preid -> ty list -> ty -> lsymbol
val create_psymbol : preid -> ty list -> lsymbol
val create_lsymbol : ?opaque:Stv.t -> preid -> ty list -> ty option -> lsymbol
val create_fsymbol : ?opaque:Stv.t -> preid -> ty list -> ty -> lsymbol
val create_psymbol : ?opaque:Stv.t -> preid -> ty list -> lsymbol
val ls_ty_freevars : lsymbol -> Stv.t
......
......@@ -384,7 +384,38 @@ let add_prop uc (_,pr,_) = add_symbol add_pr pr.pr_name pr uc
let create_decl d = mk_tdecl (Decl d)
let check_subst_opacity ls ls' sbs =
(* the definition of ls contains ls' instantiated with sbs *)
let sbs = Mtv.set_diff sbs ls'.ls_opaque in
let check () tv = if Stv.mem tv ls.ls_opaque then
Loc.errorm "type parameter '%s is not opaque in symbol `%s'"
tv.tv_name.id_string ls.ls_name.id_string in
Mtv.iter (fun _ ty -> ty_v_fold check () ty) sbs
let check_decl_opacity d = match d.d_node with
(* All lsymbols declared in Ddata are safe, nothing to check.
We allow arbitrary ls_opaque in Dparam, but we check that
cloning in theories preserves opacity, see cl_init below. *)
| Dtype _ | Ddata _ | Dparam _ | Dprop _ -> ()
| Dlogic dl ->
let check (ols,ld) =
let check () ls args value =
let sbs = oty_match Mtv.empty ls.ls_value value in
let sbs = List.fold_left2 ty_match sbs ls.ls_args args in
check_subst_opacity ols ls sbs in
if not (Stv.is_empty ols.ls_opaque) then
t_app_fold check () (snd (open_ls_defn ld))
in
List.iter check dl
| Dind (_, dl) ->
(* TODO: are there safe classes of inductive predicates? *)
let check (ls,_) = if not (Stv.is_empty ls.ls_opaque) then
Loc.errorm ?loc:ls.ls_name.id_loc
"inductive predicates cannot have opaque type parameters" in
List.iter check dl
let add_decl uc d =
check_decl_opacity d; (* we don't care about tasks *)
let uc = add_tdecl uc (create_decl d) in
match d.d_node with
| Dtype ts -> add_symbol add_ts ts.ts_name ts uc
......@@ -473,9 +504,10 @@ let cl_find_ls cl ls =
if not (Sid.mem ls.ls_name cl.cl_local) then ls
else try Mls.find ls cl.ls_table
with Not_found ->
let opaque = ls.ls_opaque in
let ta' = List.map (cl_trans_ty cl) ls.ls_args in
let vt' = Opt.map (cl_trans_ty cl) ls.ls_value in
let ls' = create_lsymbol (id_clone ls.ls_name) ta' vt' in
let ls' = create_lsymbol ~opaque (id_clone ls.ls_name) ta' vt' in
cl.ls_table <- Mls.add ls ls' cl.ls_table;
ls'
......@@ -513,8 +545,10 @@ let cl_init_ls cl ls ls' =
| None, None -> Mtv.empty
| _ -> raise (BadInstance (id, ls'.ls_name))
in
ignore (try List.fold_left2 mtch sb ls.ls_args ls'.ls_args
with Invalid_argument _ -> raise (BadInstance (id, ls'.ls_name)));
let sb = try List.fold_left2 mtch sb ls.ls_args ls'.ls_args
with Invalid_argument _ -> raise (BadInstance (id, ls'.ls_name))
in
check_subst_opacity ls ls' sb;
cl.ls_table <- Mls.add ls ls' cl.ls_table
let cl_init_pr cl pr =
......@@ -639,7 +673,8 @@ let warn_clone_not_abstract loc th =
end
| _ -> ()
) th.th_decls;
Warning.emit ~loc "cloned theory %a.%s does not contain any abstract symbol; it should be used instead"
Warning.emit ~loc "cloned theory %a.%s does not contain \
any abstract symbol; it should be used instead"
(Pp.print_list (Pp.constant_string ".") Pp.string) th.th_path
th.th_name.id_string
with Exit -> ()
......
......@@ -204,8 +204,12 @@ rule token = parse
{ LEFTPAR_STAR_RIGHTPAR }
| "(*"
{ comment_start_loc := loc lexbuf; comment lexbuf; token lexbuf }
| "'"
{ QUOTE }
| "~'" (lident as id)
{ OPAQUE_QUOTE_LIDENT id }
| "'" (lident as id)
{ QUOTE_LIDENT id }
| "'" (uident as id)
{ QUOTE_UIDENT id }
| ","
{ COMMA }
| "("
......
......@@ -65,8 +65,6 @@ end
let prefix s = "prefix " ^ s
let mixfix s = "mixfix " ^ s
let quote id = { id with id = "'" ^ id.id }
let mk_id id loc = { id = id; id_lab = []; id_loc = loc }
let add_lab id l = { id with id_lab = l }
......@@ -187,6 +185,7 @@ end
%token <Ptree.real_constant> FLOAT
%token <string> STRING
%token <Loc.position> POSITION
%token <string> QUOTE_UIDENT QUOTE_LIDENT OPAQUE_QUOTE_LIDENT
/* keywords */
......@@ -210,8 +209,7 @@ end
%token COLON COMMA
%token DOT EQUAL FUNC LAMBDA LTGT
%token LEFTPAR LEFTPAR_STAR_RIGHTPAR LEFTSQ
%token LARROW LRARROW
%token OR PRED QUOTE
%token LARROW LRARROW OR PRED
%token RIGHTPAR RIGHTSQ
%token UNDERSCORE
......@@ -424,8 +422,8 @@ late_invariant:
;
type_args:
| /* epsilon */ { [] }
| type_var labels type_args { add_lab $1 $2 :: $3 }
| /* epsilon */ { [] }
| quote_lident labels type_args { add_lab $1 $2 :: $3 }
;
typedefn:
......@@ -592,8 +590,10 @@ primitive_type_arg:
primitive_type_arg_non_lident:
| uqualid DOT lident
{ PPTtyapp (Qdot ($1, $3), []) }
| type_var
{ PPTtyvar $1 }
| quote_lident
{ PPTtyvar ($1, false) }
| opaque_quote_lident
{ PPTtyvar ($1, true) }
| LEFTPAR primitive_type COMMA list1_primitive_type_sep_comma RIGHTPAR
{ PPTtuple ($2 :: $4) }
| LEFTPAR RIGHTPAR
......@@ -607,10 +607,6 @@ list1_primitive_type_sep_comma:
| primitive_type COMMA list1_primitive_type_sep_comma { $1 :: $3 }
;
type_var:
| QUOTE lident { $2 }
;
/* Logic expressions */
lexpr:
......@@ -697,7 +693,7 @@ lexpr_arg:
| FALSE { mk_pp PPfalse }
| OPPREF lexpr_arg { mk_l_prefix $1 $2 }
| lexpr_sub { $1 }
| QUOTE uident { mk_pp (PPvar (Qident (quote $2))) }
| quote_uident { mk_pp (PPvar (Qident $1)) }
;
lexpr_dot:
......@@ -826,8 +822,10 @@ list1_binder:
;
binder:
| type_var
{ [floc (), None, false, Some (PPTtyvar $1)] }
| quote_lident
{ [floc (), None, false, Some (PPTtyvar ($1, false))] }
| opaque_quote_lident
{ [floc (), None, false, Some (PPTtyvar ($1, true))] }
| lqualid_qualified
{ [floc (), None, false, Some (PPTtyapp ($1, []))] }
| lident labels
......@@ -938,6 +936,18 @@ lident_keyword:
| MODEL { "model" }
;
quote_uident:
| QUOTE_UIDENT { mk_id ("'" ^ $1) (floc ()) }
;
quote_lident:
| QUOTE_LIDENT { mk_id $1 (floc ()) }
;
opaque_quote_lident:
| OPAQUE_QUOTE_LIDENT { mk_id $1 (floc ()) }
;
/* Idents + symbolic operations' names */
ident_rich:
......@@ -1213,8 +1223,8 @@ expr:
{ mk_expr (Ematch ($2, $5)) }
| MATCH expr COMMA list1_expr_sep_comma WITH bar_ program_match_cases END
{ mk_expr (Ematch (mk_expr (Etuple ($2::$4)), $7)) }
| QUOTE uident COLON expr %prec prec_mark
{ mk_expr (Emark (quote $2, $4)) }
| quote_uident COLON expr %prec prec_mark
{ mk_expr (Emark ($1, $3)) }
| LOOP loop_annotation expr END
{ mk_expr (Eloop ($2, $3)) }
| WHILE expr DO loop_annotation expr DONE
......
......@@ -38,8 +38,10 @@ type qualid =
| Qident of ident
| Qdot of qualid * ident
type opacity = bool
type pty =
| PPTtyvar of ident
| PPTtyvar of ident * opacity
| PPTtyapp of qualid * pty list
| PPTtuple of pty list
......
......@@ -37,7 +37,7 @@ exception UnboundTypeVar of string
(* dead code
exception UnboundType of string list
*)
exception UnboundSymbol of string list
exception UnboundSymbol of qualid
let error = Loc.error
......@@ -72,8 +72,8 @@ let () = Exn_printer.register (fun fmt e -> match e with
| UnboundType sl ->
fprintf fmt "Unbound type '%a'" (print_list dot pp_print_string) sl
*)
| UnboundSymbol sl ->
fprintf fmt "Unbound symbol '%a'" (print_list dot pp_print_string) sl
| UnboundSymbol q ->
fprintf fmt "Unbound symbol '%a'" print_qualid q
| _ -> raise e)
let debug_parse_only = Debug.register_flag "parse_only"
......@@ -162,7 +162,7 @@ let find_ns get_id find p ns =
let r = find ns sl in
if Debug.test_flag Glob.flag then Glob.use loc (get_id r);
r
with Not_found -> error ~loc (UnboundSymbol sl)
with Not_found -> error ~loc (UnboundSymbol p)
let get_id_prop p = p.pr_name
let find_prop_ns = find_ns get_id_prop ns_find_pr
......@@ -194,7 +194,7 @@ let find_namespace q uc = find_namespace_ns q (get_namespace uc)
*)
let rec dty uc = function
| PPTtyvar {id=x} ->
| PPTtyvar ({id=x}, _) ->
create_user_type_var x
| PPTtyapp (x, p) ->
let ts = find_tysymbol x uc in
......@@ -205,7 +205,7 @@ let rec dty uc = function
tyapp ts (List.map (dty uc) tyl)
let rec ty_of_pty uc = function
| PPTtyvar {id=x} ->
| PPTtyvar ({id=x}, _) ->
ty_var (create_user_tv x)
| PPTtyapp (x, p) ->
let ts = find_tysymbol x uc in
......@@ -215,6 +215,16 @@ let rec ty_of_pty uc = function
let ts = ts_tuple (List.length tyl) in
ty_app ts (List.map (ty_of_pty uc) tyl)
let rec opaque_tvs acc = function
| Ptree.PPTtyvar (id, true) -> Stv.add (create_user_tv id.id) acc
| Ptree.PPTtyvar (_, false) -> acc
| Ptree.PPTtyapp (_, pl)
| Ptree.PPTtuple pl -> List.fold_left opaque_tvs acc pl
let opaque_tvs args value =
let acc = Opt.fold opaque_tvs Stv.empty value in
List.fold_left (fun acc (_,_,_,ty) -> opaque_tvs acc ty) acc args
let specialize_lsymbol p uc =
let s = find_lsymbol p uc in
let tl,ty = specialize_lsymbol ~loc:(qloc p) s in
......@@ -671,54 +681,6 @@ and dtype_args ~localize ls loc uc env el tl =
in
check_arg (el, tl)
(** Add projection functions for the algebraic types *)
(*
let add_projection cl p (fs,tyarg,tyval) th =
let vs = create_vsymbol (id_fresh p) tyval in
let per_cs (_,id,pl) =
let cs = find_lsymbol (Qident id) th in
let tc = match cs.ls_value with
| None -> assert false
| Some t -> t
in
let m = ty_match Mtv.empty tc tyarg in
let per_param ty (n,_) = match n with
| Some id when id.id = p -> pat_var vs
| _ -> pat_wild (ty_inst m ty)
in
let al = List.map2 per_param cs.ls_args pl in
t_close_branch (pat_app cs al tyarg) (t_var vs)
in
let vs = create_vsymbol (id_fresh "u") tyarg in
let t = t_case (t_var vs) (List.map per_cs cl) in
let d = make_ls_defn fs [vs] t in
add_logic_decl th [d]
let add_projections th d = match d.td_def with
| TDabstract | TDalias _ -> th
| TDrecord _ -> assert false
| TDalgebraic cl ->
let per_cs acc (_,id,pl) =
let cs = find_lsymbol (Qident id) th in
let tc = match cs.ls_value with
| None -> assert false
| Some t -> t
in
let per_param acc ty (n,_) = match n with
| Some id when not (Mstr.mem id.id acc) ->
let fn = create_user_id id in
let fs = create_fsymbol fn [tc] ty in
Mstr.add id.id (fs,tc,ty) acc
| _ -> acc
in
List.fold_left2 per_param acc cs.ls_args pl
in
let ps = List.fold_left per_cs Mstr.empty cl in
try Mstr.fold (add_projection cl) ps th
with e -> raise (Loc.Located (d.td_loc, e))
*)
(** Typing declarations, that is building environments. *)
open Ptree
......@@ -751,7 +713,7 @@ let add_types dl th =
let ts = match d.td_def with
| TDalias ty ->
let rec apply = function
| PPTtyvar v ->
| PPTtyvar (v, _) ->
begin
try ty_var (Hstr.find vars v.id)
with Not_found -> error ~loc:v.id_loc (UnboundTypeVar v.id)
......@@ -801,6 +763,7 @@ let add_types dl th =
| TDalias _ -> abstr, algeb, ts::alias
| TDalgebraic cl ->
let ht = Hstr.create 17 in
let opaque = Stv.of_list ts.ts_args in
let ty = ty_app ts (List.map ty_var ts.ts_args) in
let projection (_,id,_,_) fty = match id with
| None -> None
......@@ -812,7 +775,7 @@ let add_types dl th =
Some pj
with Not_found ->
let fn = create_user_id id in
let pj = create_fsymbol fn [ty] fty in
let pj = create_fsymbol ~opaque fn [ty] fty in
Hstr.replace csymbols id.id id.id_loc;
Hstr.replace ht id.id pj;
Some pj
......@@ -821,7 +784,7 @@ let add_types dl th =
let tyl = param_tys th' pl in
let pjl = List.map2 projection pl tyl in
Hstr.replace csymbols id.id loc;
create_fsymbol (create_user_id id) tyl ty, pjl
create_fsymbol ~opaque (create_user_id id) tyl ty, pjl
in
abstr, (ts, List.map constructor cl) :: algeb, alias
| TDrecord _ ->
......@@ -869,8 +832,7 @@ let env_of_vsymbol_list vl =
List.fold_left (fun env v -> Mstr.add v.vs_name.id_string v env) Mstr.empty vl
let add_logics dl th =
let fsymbols = Hstr.create 17 in
let psymbols = Hstr.create 17 in
let lsymbols = Hstr.create 17 in
let denvs = Hstr.create 17 in
(* 1. create all symbols and make an environment with these symbols *)
let create_symbol th d =
......@@ -879,18 +841,11 @@ let add_logics dl th =
Hstr.add denvs id denv;
let v = create_user_id d.ld_ident in
let pl = param_tys th d.ld_params in
let add d = match d.ld_type with
| None -> (* predicate *)
let ps = create_psymbol v pl in
Hstr.add psymbols id ps;
add_param_decl th ps
| Some t -> (* function *)
let t = ty_of_dty (dty th t) in
let fs = create_fsymbol v pl t in
Hstr.add fsymbols id fs;
add_param_decl th fs
in
Loc.try1 d.ld_loc add d
let ty = Opt.map (fun t -> ty_of_dty (dty th t)) d.ld_type in
let opaque = opaque_tvs d.ld_params d.ld_type in
let ls = create_lsymbol ~opaque v pl ty in
Hstr.add lsymbols id ls;
Loc.try2 d.ld_loc add_param_decl th ls
in
let th' = List.fold_left create_symbol th dl in
(* 2. then type-check all definitions *)
......@@ -907,41 +862,54 @@ let add_logics dl th =
| Some id -> create_user_id id
| None -> id_user "_" loc in
create_vsymbol id ty in
let mk_vlist tyl = List.map2 create_var d.ld_params tyl in
match d.ld_type with
| None -> (* predicate *)
let ps = Hstr.find psymbols id in
begin match d.ld_def with
| None -> ps :: abst, defn
| Some f ->
let f = dfmla th' denv f in
let vl = match ps.ls_value with
| None -> mk_vlist ps.ls_args
| _ -> assert false
in
let env = env_of_vsymbol_list vl in
abst, make_ls_defn ps vl (fmla env f) :: defn
end
| Some ty -> (* function *)
let fs = Hstr.find fsymbols id in
begin match d.ld_def with
| None -> fs :: abst, defn
| Some t ->
let loc = t.pp_loc in
let ty = dty th' ty in
let t = dterm th' denv t in
unify_raise ~loc t.dt_ty ty;
let vl = match fs.ls_value with
| Some _ -> mk_vlist fs.ls_args
| _ -> assert false
in
let env = env_of_vsymbol_list vl in
abst, make_ls_defn fs vl (term env t) :: defn
end
let ls = Hstr.find lsymbols id in
let vl = List.map2 create_var d.ld_params ls.ls_args in
let env = env_of_vsymbol_list vl in
match d.ld_def, d.ld_type with
| None, _ -> ls :: abst, defn
| Some e, None -> (* predicate *)
let f = dfmla th' denv e in
abst, (ls, vl, fmla env f) :: defn
| Some e, Some ty -> (* function *)
let t = dterm th' denv e in
unify_raise ~loc:e.pp_loc t.dt_ty (dty th' ty);
abst, (ls, vl, term env t) :: defn
in
let abst,defn = List.fold_right type_decl dl ([],[]) in
(* 3. detect opacity *)
let ldefns defn =
let ht = Hls.create 3 in
let add_ls (ls,_,_) =
let tvs = oty_freevars Stv.empty ls.ls_value in
let tvs = List.fold_left ty_freevars tvs ls.ls_args in
Hls.replace ht ls tvs in
List.iter add_ls defn;
let compared s ls args value =
let sbs = oty_match Mtv.empty ls.ls_value value in
let sbs = List.fold_left2 ty_match sbs ls.ls_args args in
let opq = try Hls.find ht ls with Not_found -> ls.ls_opaque in
Mtv.fold (fun _ ty s -> ty_freevars s ty) (Mtv.set_diff sbs opq) s in
let check_ld fixp (ls,_,t) =
let opq = Hls.find ht ls in
let npq = Stv.diff opq (t_app_fold compared Stv.empty t) in
Hls.replace ht ls npq;
fixp && Stv.equal opq npq in
let rec fixp () =
if not (List.fold_left check_ld true defn) then fixp () in
fixp ();
let mk_sbs sbs ({ls_name = id} as ls,_,_) =
let opaque = Stv.union ls.ls_opaque (Hls.find ht ls) in
if Stv.equal ls.ls_opaque opaque then sbs else
let nls = create_lsymbol ~opaque (id_clone id) ls.ls_args ls.ls_value in
Mls.add ls nls sbs in
let sbs = List.fold_left mk_sbs Mls.empty defn in
let mk_ld (ls,vl,t) =
let get_ls ls = Mls.find_def ls ls sbs in
make_ls_defn (get_ls ls) vl (t_s_map (fun ty -> ty) get_ls t) in
List.map mk_ld defn
in
let th = List.fold_left add_param_decl th abst in
let th = if defn = [] then th else add_logic_decl th defn in
let th = if defn = [] then th else add_logic_decl th (ldefns defn) in
th
let type_term uc gfn t =
......@@ -968,7 +936,8 @@ let add_inductives s dl th =
let id = d.in_ident.id in
let v = create_user_id d.in_ident in
let pl = param_tys th d.in_params in
let ps = create_psymbol v pl in
let opaque = opaque_tvs d.in_params None in
let ps = create_psymbol ~opaque v pl in
Hstr.add psymbols id ps;
Loc.try2 d.in_loc add_param_decl th ps
in
......
......@@ -21,7 +21,7 @@ open Mlw_expr
type dity =
| Dvar of dvar ref
| Duvar of tvsymbol
| Duvar of tvsymbol * (* opaque *) bool
| Dits of itysymbol * dity list * dreg list
| Dts of tysymbol * dity list
......@@ -42,7 +42,7 @@ let ity_of_dity dity =
| Dvar { contents = Dtvs _ } ->
Loc.errorm "undefined type variable"
| Dvar { contents = Dval dty } -> get_ity dty
| Duvar tv -> ity_var tv
| Duvar (tv,_) -> ity_var tv
| Dits (its,dl,rl) ->
ity_app its (List.map get_ity dl) (List.map get_reg rl)
| Dts (ts,dl) -> ity_pur ts (List.map get_ity dl)
......@@ -53,8 +53,8 @@ let ity_of_dity dity =
in
get_ity dity