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
......
This diff is collapsed.
......@@ -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
let create_user_type_variable x =
Duvar (Typing.create_user_tv x.id)
let create_user_type_variable x op =
Duvar (Typing.create_user_tv x.id, op)
let create_type_variable () =
Dvar (ref (Dtvs (create_tvsymbol (id_fresh "a"))))
......@@ -118,12 +118,19 @@ let rec dity_refresh = function
| Dits (its,dl,_) -> its_app its (List.map dity_refresh dl)
| Dts (ts,dl) -> ts_app_real ts (List.map dity_refresh dl)
let rec opaque_tvs acc = function
| Dvar { contents = Dtvs _ } -> acc
| Dvar { contents = Dval dty } -> opaque_tvs acc dty
| Duvar (tv,true) -> Stv.add tv acc
| Duvar (_,false) -> acc
| Dits (_,dl,_) | Dts (_,dl) -> List.fold_left opaque_tvs acc dl
(* unification *)
let rec occur_check tv = function
| Dvar { contents = Dval d } -> occur_check tv d
| Dits (_,dl,_) | Dts (_,dl) -> List.iter (occur_check tv) dl
| Dvar { contents = Dtvs tv' } | Duvar tv' ->
| Dvar { contents = Dtvs tv' } | Duvar (tv',_) ->
if tv_equal tv tv' then raise Exit
let rec occur_check_reg tv = function
......@@ -152,7 +159,7 @@ let rec unify ~weak d1 d2 = match d1,d2 with
| Dvar ({ contents = Dtvs tv } as r), d
| d, Dvar ({ contents = Dtvs tv } as r) ->
occur_check tv d; r := Dval d
| Duvar tv1, Duvar tv2 when tv_equal tv1 tv2 -> ()
| Duvar (tv1,_), Duvar (tv2,_) when tv_equal tv1 tv2 -> ()
| Dits (its1, dl1, rl1), Dits (its2, dl2, rl2) when its_equal its1 its2 ->
assert (List.length rl1 = List.length rl2);
assert (List.length dl1 = List.length dl2);
......@@ -237,7 +244,7 @@ let specialize_scheme tvs (argl,res) =
let hreg = Htv.create 17 in
let rec specialize = function
| Dvar { contents = Dval d } -> specialize d
| Dvar { contents = Dtvs tv } | Duvar tv as d ->
| Dvar { contents = Dtvs tv } | Duvar (tv,_) as d ->
if tv_in_tvars tv tvs then d else
begin try Htv.find htvs tv with Not_found ->
let v = create_type_variable () in
......@@ -341,7 +348,7 @@ let print_dity fmt dity =
let protect_on x s = if x then "(" ^^ s ^^ ")" else s in
let rec print_dity inn fmt = function
| Dvar { contents = Dtvs tv }
| Duvar tv ->
| Duvar (tv,_) ->
Pretty.print_tv fmt tv
| Dvar { contents = Dval dty } ->
print_dity inn fmt dty
......
......@@ -30,12 +30,14 @@ val add_dvty: tvars -> dvty -> tvars
val add_dvty_vars: tvars -> dvty -> tvars (* add only variables *)
val create_type_variable: unit -> dity
val create_user_type_variable: Ptree.ident -> dity
val create_user_type_variable: Ptree.ident -> (* opaque *) bool -> dity
val its_app: itysymbol -> dity list -> dity
val ts_app: tysymbol -> dity list -> dity
val dity_refresh: dity -> dity (* refresh regions *)
val opaque_tvs: Stv.t -> dity -> Stv.t
val is_chainable: dvty -> bool (* non-bool * non-bool -> bool *)
exception DTypeMismatch of dity * dity
......
......@@ -53,7 +53,10 @@ let create_plsymbol ?(hidden=false) ?(rdonly=false) id args value =
Opt.iter (fun r -> ity_equal_check fd.fd_ity r.reg_ity) fd.fd_mut;
ty_of_ity fd.fd_ity in
let pure_args = List.map ty_of_field args in
let ls = create_fsymbol id pure_args (ty_of_field value) in
let pure_value = ty_of_field value in
(* plsymbols are used for constructors and projections, which are safe *)
let opaque = List.fold_left ty_freevars Stv.empty (pure_value::pure_args) in
let ls = create_fsymbol ~opaque id pure_args pure_value in
create_plsymbol_unsafe ls args value ~hidden ~rdonly
let ity_of_ty_opt ty = ity_of_ty (Opt.get_def ty_bool ty)
......@@ -571,11 +574,12 @@ let e_plapp pls el ity =
if pls.pl_rdonly then raise (RdOnlyPLS pls);
let rec app tl varm ghost eff sbs fdl argl = match fdl, argl with
| [],[] ->
let mut_fold fn eff fd = match fd.fd_mut with
| Some r -> fn eff (reg_full_inst sbs r)
| None -> eff in
let eff = List.fold_left (mut_fold eff_reset) eff pls.pl_args in
let eff = mut_fold (eff_read ~ghost) eff pls.pl_value in
let mut_fold fn leff fd = Opt.fold fn leff fd.fd_mut in
let leff = mut_fold (eff_read ~ghost) eff_empty pls.pl_value in
let leff = List.fold_left (mut_fold eff_reset) leff pls.pl_args in
let mtv = Mtv.set_diff sbs.ity_subst_tv pls.pl_ls.ls_opaque in
let leff = Mtv.fold (fun tv _ e -> eff_compare e tv) mtv leff in
let eff = eff_union eff (eff_full_inst sbs leff) in
let t = match pls.pl_ls.ls_value with
| Some _ -> fs_app pls.pl_ls tl (ty_of_ity ity)
| None -> ps_app pls.pl_ls tl in
......
......@@ -456,6 +456,9 @@ let () = Exn_printer.register
fprintf fmt "The type of exception %s has mutable components" id.id_string
| Mlw_ty.IllegalAlias _reg ->
fprintf fmt "This application creates an illegal alias"
| Mlw_ty.IllegalCompar (tv,_ity) ->
fprintf fmt "This application instantiates \
a non-opaque type parameter %a with a program type" print_tv tv
| Mlw_ty.GhostDiverg ->
fprintf fmt "This ghost expression contains potentially \
non-terminating loops or function calls"
......
......@@ -552,6 +552,7 @@ type effect = {
eff_ghostx : Sexn.t; (* ghost raises *)
(* if r1 -> Some r2 then r1 appears in ty(r2) *)
eff_resets : region option Mreg.t;
eff_compar : Stv.t;
eff_diverg : bool;
}
......@@ -563,6 +564,7 @@ let eff_empty = {
eff_ghostw = Sreg.empty;
eff_ghostx = Sexn.empty;
eff_resets = Mreg.empty;
eff_compar = Stv.empty;
eff_diverg = false;
}
......@@ -574,6 +576,7 @@ let eff_is_empty e =
Sreg.is_empty e.eff_ghostw &&
Sexn.is_empty e.eff_ghostx &&
Mreg.is_empty e.eff_resets &&
(* eff_compar is not a side effect *)
not e.eff_diverg
let eff_equal e1 e2 =
......@@ -584,6 +587,7 @@ let eff_equal e1 e2 =
Sreg.equal e1.eff_ghostw e2.eff_ghostw &&
Sexn.equal e1.eff_ghostx e2.eff_ghostx &&
Mreg.equal (Opt.equal reg_equal) e1.eff_resets e2.eff_resets &&
Stv.equal e1.eff_compar e2.eff_compar &&
e1.eff_diverg = e2.eff_diverg
let join_reset _key v1 v2 = match v1, v2 with
......@@ -602,6 +606,7 @@ let eff_union x y = {
eff_ghostw = Sreg.union x.eff_ghostw y.eff_ghostw;
eff_ghostx = Sexn.union x.eff_ghostx y.eff_ghostx;
eff_resets = Mreg.union join_reset x.eff_resets y.eff_resets;
eff_compar = Stv.union x.eff_compar y.eff_compar;
eff_diverg = x.eff_diverg || y.eff_diverg;
}
......@@ -615,6 +620,13 @@ let eff_ghostify e = {
eff_ghostw = Sreg.union e.eff_writes e.eff_ghostw;
eff_ghostx = Sexn.union e.eff_raises e.eff_ghostx;
eff_resets = e.eff_resets;
eff_compar = e.eff_compar;
(* from the code extraction point of view, we can allow comparing
opaque types in the ghost code, as it is never extracted.
However, if we consider Coq realisations, we have to treat
some pure types (e.g., maps) as opaque, too, and never compare
them even in pure formulas. Therefore, we play safe and forbid
comparison of opaque types in the ghost code. *)
eff_diverg = if e.eff_diverg then raise GhostDiverg else false;
}
......@@ -634,9 +646,12 @@ let eff_raise e ?(ghost=false) x = if ghost
let eff_reset e r = { e with eff_resets = Mreg.add r None e.eff_resets }
let eff_compare e tv = { e with eff_compar = Stv.add tv e.eff_compar }
let eff_diverge e = { e with eff_diverg = true }
exception IllegalAlias of region
exception IllegalCompar of tvsymbol * ity
let eff_refresh e r u =
if not (reg_occurs r u.reg_ity.ity_vars) then
......@@ -669,8 +684,8 @@ let eff_remove_raise e x = { e with
eff_ghostx = Sexn.remove x e.eff_ghostx;
}
let eff_full_inst s e =
let s = s.ity_subst_reg in
let eff_full_inst sbs e =
let s = sbs.ity_subst_reg in
(* modified or reset regions in e *)
let wr = Mreg.map (Util.const ()) e.eff_resets in
let wr = Sreg.union e.eff_writes wr in
......@@ -689,12 +704,19 @@ let eff_full_inst s e =
let add_sreg r acc = Sreg.add (Mreg.find r s) acc in
let add_mreg r v acc =
Mreg.add (Mreg.find r s) (Opt.map (fun v -> Mreg.find v s) v) acc in
(* compute compared type variables *)
let add_stv tv acc =
let ity = Mtv.find tv sbs.ity_subst_tv in
let check () _ = raise (IllegalCompar (tv,ity)) in
ity_s_fold check (fun () _ -> ()) () ity;
Stv.union acc ity.ity_vars.vars_tv in
{ e with
eff_reads = Sreg.fold add_sreg e.eff_reads Sreg.empty;
eff_writes = Sreg.fold add_sreg e.eff_writes Sreg.empty;
eff_ghostr = Sreg.fold add_sreg e.eff_ghostr Sreg.empty;
eff_ghostw = Sreg.fold add_sreg e.eff_ghostw Sreg.empty;
eff_resets = Mreg.fold add_mreg e.eff_resets Mreg.empty;
eff_compar = Stv.fold add_stv e.eff_compar Stv.empty;
}
let eff_filter vars e =
......@@ -710,6 +732,7 @@ let eff_filter vars e =
eff_ghostr = Sreg.filter check e.eff_ghostr;
eff_ghostw = Sreg.filter check e.eff_ghostw;
eff_resets = Mreg.mapi_filter reset e.eff_resets;
eff_compar = Stv.inter vars.vars_tv e.eff_compar;
}
let eff_stale_region eff vars =
......
......@@ -204,6 +204,7 @@ type effect = private {
eff_ghostx : Sexn.t; (* ghost raises *)
(* if r1 -> Some r2 then r1 appears in ty(r2) *)
eff_resets : region option Mreg.t;
eff_compar : Stv.t;
eff_diverg : bool;
}
......@@ -220,6 +221,7 @@ val eff_reset : effect -> region -> effect
val eff_refresh : effect -> region -> region -> effect
val eff_assign : effect -> ?ghost:bool -> region -> ity -> effect
val eff_compare : effect -> tvsymbol -> effect
val eff_diverge : effect -> effect
val eff_remove_raise : effect -> xsymbol -> effect
......@@ -227,6 +229,7 @@ val eff_remove_raise : effect -> xsymbol -> effect
val eff_stale_region : effect -> varset -> bool
exception IllegalAlias of region
exception IllegalCompar of tvsymbol * ity
exception GhostDiverg
val eff_full_inst : ity_subst -> effect -> effect
......
......@@ -165,8 +165,8 @@ let uc_find_ps uc p =
(** Typing type expressions *)
let rec dity_of_pty denv = function
| Ptree.PPTtyvar id ->
create_user_type_variable id
| Ptree.PPTtyvar (id, op) ->
create_user_type_variable id op
| Ptree.PPTtyapp (p, pl) ->
let dl = List.map (dity_of_pty denv) pl in
begin match uc_find_ts denv.uc p with
......@@ -177,6 +177,9 @@ let rec dity_of_pty denv = function
let dl = List.map (dity_of_pty denv) pl in
ts_app (ts_tuple (List.length pl)) dl
let opaque_binders acc args =
List.fold_left (fun acc (_,_,dty) -> opaque_tvs acc dty) acc args
(** Typing program expressions *)
let dity_int = ts_app ts_int []
......@@ -209,6 +212,31 @@ let rec extract_labels labs loc e = match e.Ptree.expr_desc with
labs, loc, Ptree.Ecast ({ e with Ptree.expr_desc = d }, ty)
| e -> labs, loc, e
(* Hack alert. Since the result type in "let [rec] fn x y : ty = ..."
is moved to Ecast and then usually lost in destructive unification,
we try to preserve opacity annotations by moving them to binders. *)
let pass_opacity (e,_) bl =
let rec find e = match e.Ptree.expr_desc with
| Ptree.Ecast (_, pty) -> Some pty
| Ptree.Enamed (_, e) -> find e
| _ -> None in
match find e with
| Some pty ->
let ht = Hstr.create 3 in
let rec fill = function
| Ptree.PPTtyapp (_, pl) | Ptree.PPTtuple pl -> List.iter fill pl
| Ptree.PPTtyvar (id, true) -> Hstr.replace ht id.id ()
| Ptree.PPTtyvar _ -> () in
fill pty;
if Hstr.length ht = 0 then bl else
let rec pass = function
| Ptree.PPTtyvar (id,op) -> Ptree.PPTtyvar (id, op || Hstr.mem ht id.id)
| Ptree.PPTtyapp (p, pl) -> Ptree.PPTtyapp (p, List.map pass pl)
| Ptree.PPTtuple pl -> Ptree.PPTtuple (List.map pass pl) in
List.map (fun (loc,id,gh,pty) -> loc, id, gh, Opt.map pass pty) bl
| None ->
bl
let rec decompose_app args e = match e.Ptree.expr_desc with
| Eapply (e1, e2) -> decompose_app (e2 :: args) e1
| _ -> e, args
......@@ -539,7 +567,7 @@ and de_desc denv loc = function
let e1 = dexpr denv e1 in
DEletrec (fdl, e1), e1.de_type
| Ptree.Efun (bl, tr) ->
let denv, bl, tyl = dbinders denv bl in
let denv, bl, tyl = dbinders denv (pass_opacity tr bl) in
let tr, (argl, res) = dtriple denv tr in
DEfun (bl, tr), (tyl @ argl, res)
| Ptree.Ecast (e1, pty) ->
......@@ -707,8 +735,8 @@ and dletrec denv fdl =
add_mono id dvty denv, dvty in
let denv, dvtyl = Lists.map_fold_left add_one denv fdl in
(* then unify the binders *)
let bind_one (_,_,_,bl,_) (argl,res) =
let denv,bl,tyl = dbinders denv bl in
let bind_one (_,_,_,bl,tr) (argl,res) =
let denv,bl,tyl = dbinders denv (pass_opacity tr bl) in
List.iter2 unify argl tyl;
denv,bl,tyl,res in
let denvl = List.map2 bind_one fdl dvtyl in
......@@ -1170,7 +1198,7 @@ let eff_of_deff lenv dsp =
let add_raise xs _ eff = eff_raise eff xs in
Mexn.fold add_raise dsp.ds_xpost eff, svs
let check_user_effect lenv e dsp =
let check_user_effect lenv e otv dsp =
let acc = eff_empty, Svs.empty in
let read le eff ?(ghost=false) reg =
ignore ghost;
......@@ -1193,7 +1221,10 @@ let check_user_effect lenv e dsp =
Sexn.mem xs e.e_effect.eff_ghostx
then () else Loc.errorm
"this expression does not raise exception %a" print_xs xs in
Mexn.iter check_raise dsp.ds_xpost
Mexn.iter check_raise dsp.ds_xpost;
let bad_comp tv _ _ = Loc.errorm
"type parameter %a is not opaque in this expression" Pretty.print_tv tv in
ignore (Mtv.inter bad_comp otv e.e_effect.eff_compar)
let spec_of_dspec lenv eff vty dsp = {
c_pre = create_pre lenv dsp.ds_pre;
......@@ -1204,8 +1235,8 @@ let spec_of_dspec lenv eff vty dsp = {
c_letrec = 0;
}
let rec type_c lenv pvs vars (dtyv, dsp) =
let vty = type_v lenv pvs vars dtyv in
let rec type_c lenv pvs vars otv (dtyv, dsp) =
let vty = type_v lenv pvs vars otv dtyv in
let eff, esvs = eff_of_deff lenv dsp in
(* reset every new region in the result *)
let eff = match vty with
......@@ -1219,6 +1250,10 @@ let rec type_c lenv pvs vars (dtyv, dsp) =
let on_reg r e = if Sreg.mem r writes then e else eff_refresh e r u in
reg_fold on_reg u.reg_ity.ity_vars eff in
let eff = Sreg.fold check writes eff in
(* eff_compare every type variable not marked as opaque *)
let otv = match dtyv with DSpecV v -> opaque_tvs otv v | _ -> otv in
let eff = Stv.fold_left eff_compare eff (Stv.diff vars.vars_tv otv) in
(* make spec *)
let spec = spec_of_dspec lenv eff vty dsp in
if spec.c_variant <> [] then Loc.errorm
"variants are not allowed in a parameter declaration";
......@@ -1239,16 +1274,17 @@ let rec type_c lenv pvs vars (dtyv, dsp) =
(* add the invariants *)
spec_invariant lenv pvs vty spec, vty
and type_v lenv pvs vars = function
and type_v lenv pvs vars otv = function