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 = { ...@@ -45,6 +45,7 @@ type lsymbol = {
ls_name : ident; ls_name : ident;
ls_args : ty list; ls_args : ty list;
ls_value : ty option; ls_value : ty option;
ls_opaque : Stv.t;
} }
module Lsym = MakeMSHW (struct module Lsym = MakeMSHW (struct
...@@ -61,14 +62,21 @@ let ls_equal : lsymbol -> lsymbol -> bool = (==) ...@@ -61,14 +62,21 @@ let ls_equal : lsymbol -> lsymbol -> bool = (==)
let ls_hash ls = id_hash ls.ls_name 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_name = id_register name;
ls_args = args; ls_args = args;
ls_value = value; ls_value = value;
ls_opaque = check_opaque opaque args value;
} }
let create_fsymbol nm al vl = create_lsymbol nm al (Some vl) let create_fsymbol ?opaque nm al vl = create_lsymbol ?opaque nm al (Some vl)
let create_psymbol nm al = create_lsymbol nm al (None) let create_psymbol ?opaque nm al = create_lsymbol ?opaque nm al (None)
let ls_ty_freevars ls = let ls_ty_freevars ls =
let acc = oty_freevars Stv.empty ls.ls_value in let acc = oty_freevars Stv.empty ls.ls_value in
...@@ -795,9 +803,11 @@ let fs_tuple_ids = Hid.create 17 ...@@ -795,9 +803,11 @@ let fs_tuple_ids = Hid.create 17
let fs_tuple = Hint.memo 17 (fun n -> let fs_tuple = Hint.memo 17 (fun n ->
let ts = ts_tuple n in 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 tl = List.map ty_var ts.ts_args in
let ty = ty_app ts tl 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; Hid.add fs_tuple_ids fs.ls_name n;
fs) fs)
......
...@@ -38,6 +38,7 @@ type lsymbol = private { ...@@ -38,6 +38,7 @@ type lsymbol = private {
ls_name : ident; ls_name : ident;
ls_args : ty list; ls_args : ty list;
ls_value : ty option; ls_value : ty option;
ls_opaque : Stv.t;
} }
module Mls : Extmap.S with type key = lsymbol module Mls : Extmap.S with type key = lsymbol
...@@ -48,9 +49,9 @@ module Wls : Weakhtbl.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_equal : lsymbol -> lsymbol -> bool
val ls_hash : lsymbol -> int val ls_hash : lsymbol -> int
val create_lsymbol : preid -> ty list -> ty option -> lsymbol val create_lsymbol : ?opaque:Stv.t -> preid -> ty list -> ty option -> lsymbol
val create_fsymbol : preid -> ty list -> ty -> lsymbol val create_fsymbol : ?opaque:Stv.t -> preid -> ty list -> ty -> lsymbol
val create_psymbol : preid -> ty list -> lsymbol val create_psymbol : ?opaque:Stv.t -> preid -> ty list -> lsymbol
val ls_ty_freevars : lsymbol -> Stv.t 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 ...@@ -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 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 = let add_decl uc d =
check_decl_opacity d; (* we don't care about tasks *)
let uc = add_tdecl uc (create_decl d) in let uc = add_tdecl uc (create_decl d) in
match d.d_node with match d.d_node with
| Dtype ts -> add_symbol add_ts ts.ts_name ts uc | Dtype ts -> add_symbol add_ts ts.ts_name ts uc
...@@ -473,9 +504,10 @@ let cl_find_ls cl ls = ...@@ -473,9 +504,10 @@ let cl_find_ls cl ls =
if not (Sid.mem ls.ls_name cl.cl_local) then ls if not (Sid.mem ls.ls_name cl.cl_local) then ls
else try Mls.find ls cl.ls_table else try Mls.find ls cl.ls_table
with Not_found -> with Not_found ->
let opaque = ls.ls_opaque in
let ta' = List.map (cl_trans_ty cl) ls.ls_args 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 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; cl.ls_table <- Mls.add ls ls' cl.ls_table;
ls' ls'
...@@ -513,8 +545,10 @@ let cl_init_ls cl ls ls' = ...@@ -513,8 +545,10 @@ let cl_init_ls cl ls ls' =
| None, None -> Mtv.empty | None, None -> Mtv.empty
| _ -> raise (BadInstance (id, ls'.ls_name)) | _ -> raise (BadInstance (id, ls'.ls_name))
in in
ignore (try List.fold_left2 mtch sb ls.ls_args ls'.ls_args let sb = try List.fold_left2 mtch sb ls.ls_args ls'.ls_args
with Invalid_argument _ -> raise (BadInstance (id, ls'.ls_name))); 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 cl.ls_table <- Mls.add ls ls' cl.ls_table
let cl_init_pr cl pr = let cl_init_pr cl pr =
...@@ -639,7 +673,8 @@ let warn_clone_not_abstract loc th = ...@@ -639,7 +673,8 @@ let warn_clone_not_abstract loc th =
end end
| _ -> () | _ -> ()
) th.th_decls; ) 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 (Pp.print_list (Pp.constant_string ".") Pp.string) th.th_path
th.th_name.id_string th.th_name.id_string
with Exit -> () with Exit -> ()
......
...@@ -204,8 +204,12 @@ rule token = parse ...@@ -204,8 +204,12 @@ rule token = parse
{ LEFTPAR_STAR_RIGHTPAR } { LEFTPAR_STAR_RIGHTPAR }
| "(*" | "(*"
{ comment_start_loc := loc lexbuf; comment lexbuf; token lexbuf } { comment_start_loc := loc lexbuf; comment lexbuf; token lexbuf }
| "'" | "~'" (lident as id)
{ QUOTE } { OPAQUE_QUOTE_LIDENT id }
| "'" (lident as id)
{ QUOTE_LIDENT id }
| "'" (uident as id)
{ QUOTE_UIDENT id }
| "," | ","
{ COMMA } { COMMA }
| "(" | "("
......
...@@ -65,8 +65,6 @@ end ...@@ -65,8 +65,6 @@ end
let prefix s = "prefix " ^ s let prefix s = "prefix " ^ s
let mixfix s = "mixfix " ^ 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 mk_id id loc = { id = id; id_lab = []; id_loc = loc }
let add_lab id l = { id with id_lab = l } let add_lab id l = { id with id_lab = l }
...@@ -187,6 +185,7 @@ end ...@@ -187,6 +185,7 @@ end
%token <Ptree.real_constant> FLOAT %token <Ptree.real_constant> FLOAT
%token <string> STRING %token <string> STRING
%token <Loc.position> POSITION %token <Loc.position> POSITION
%token <string> QUOTE_UIDENT QUOTE_LIDENT OPAQUE_QUOTE_LIDENT
/* keywords */ /* keywords */
...@@ -210,8 +209,7 @@ end ...@@ -210,8 +209,7 @@ end
%token COLON COMMA %token COLON COMMA
%token DOT EQUAL FUNC LAMBDA LTGT %token DOT EQUAL FUNC LAMBDA LTGT
%token LEFTPAR LEFTPAR_STAR_RIGHTPAR LEFTSQ %token LEFTPAR LEFTPAR_STAR_RIGHTPAR LEFTSQ
%token LARROW LRARROW %token LARROW LRARROW OR PRED
%token OR PRED QUOTE
%token RIGHTPAR RIGHTSQ %token RIGHTPAR RIGHTSQ
%token UNDERSCORE %token UNDERSCORE
...@@ -424,8 +422,8 @@ late_invariant: ...@@ -424,8 +422,8 @@ late_invariant:
; ;
type_args: type_args:
| /* epsilon */ { [] } | /* epsilon */ { [] }
| type_var labels type_args { add_lab $1 $2 :: $3 } | quote_lident labels type_args { add_lab $1 $2 :: $3 }
; ;
typedefn: typedefn:
...@@ -592,8 +590,10 @@ primitive_type_arg: ...@@ -592,8 +590,10 @@ primitive_type_arg:
primitive_type_arg_non_lident: primitive_type_arg_non_lident:
| uqualid DOT lident | uqualid DOT lident
{ PPTtyapp (Qdot ($1, $3), []) } { PPTtyapp (Qdot ($1, $3), []) }
| type_var | quote_lident
{ PPTtyvar $1 } { PPTtyvar ($1, false) }
| opaque_quote_lident
{ PPTtyvar ($1, true) }
| LEFTPAR primitive_type COMMA list1_primitive_type_sep_comma RIGHTPAR | LEFTPAR primitive_type COMMA list1_primitive_type_sep_comma RIGHTPAR
{ PPTtuple ($2 :: $4) } { PPTtuple ($2 :: $4) }
| LEFTPAR RIGHTPAR | LEFTPAR RIGHTPAR
...@@ -607,10 +607,6 @@ list1_primitive_type_sep_comma: ...@@ -607,10 +607,6 @@ list1_primitive_type_sep_comma:
| primitive_type COMMA list1_primitive_type_sep_comma { $1 :: $3 } | primitive_type COMMA list1_primitive_type_sep_comma { $1 :: $3 }
; ;
type_var:
| QUOTE lident { $2 }
;
/* Logic expressions */ /* Logic expressions */
lexpr: lexpr:
...@@ -697,7 +693,7 @@ lexpr_arg: ...@@ -697,7 +693,7 @@ lexpr_arg:
| FALSE { mk_pp PPfalse } | FALSE { mk_pp PPfalse }
| OPPREF lexpr_arg { mk_l_prefix $1 $2 } | OPPREF lexpr_arg { mk_l_prefix $1 $2 }
| lexpr_sub { $1 } | lexpr_sub { $1 }
| QUOTE uident { mk_pp (PPvar (Qident (quote $2))) } | quote_uident { mk_pp (PPvar (Qident $1)) }
; ;
lexpr_dot: lexpr_dot:
...@@ -826,8 +822,10 @@ list1_binder: ...@@ -826,8 +822,10 @@ list1_binder:
; ;
binder: binder:
| type_var | quote_lident
{ [floc (), None, false, Some (PPTtyvar $1)] } { [floc (), None, false, Some (PPTtyvar ($1, false))] }
| opaque_quote_lident
{ [floc (), None, false, Some (PPTtyvar ($1, true))] }
| lqualid_qualified | lqualid_qualified
{ [floc (), None, false, Some (PPTtyapp ($1, []))] } { [floc (), None, false, Some (PPTtyapp ($1, []))] }
| lident labels | lident labels
...@@ -938,6 +936,18 @@ lident_keyword: ...@@ -938,6 +936,18 @@ lident_keyword:
| MODEL { "model" } | 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 */ /* Idents + symbolic operations' names */
ident_rich: ident_rich:
...@@ -1213,8 +1223,8 @@ expr: ...@@ -1213,8 +1223,8 @@ expr:
{ mk_expr (Ematch ($2, $5)) } { mk_expr (Ematch ($2, $5)) }
| MATCH expr COMMA list1_expr_sep_comma WITH bar_ program_match_cases END | MATCH expr COMMA list1_expr_sep_comma WITH bar_ program_match_cases END
{ mk_expr (Ematch (mk_expr (Etuple ($2::$4)), $7)) } { mk_expr (Ematch (mk_expr (Etuple ($2::$4)), $7)) }
| QUOTE uident COLON expr %prec prec_mark | quote_uident COLON expr %prec prec_mark
{ mk_expr (Emark (quote $2, $4)) } { mk_expr (Emark ($1, $3)) }
| LOOP loop_annotation expr END | LOOP loop_annotation expr END
{ mk_expr (Eloop ($2, $3)) } { mk_expr (Eloop ($2, $3)) }
| WHILE expr DO loop_annotation expr DONE | WHILE expr DO loop_annotation expr DONE
......
...@@ -38,8 +38,10 @@ type qualid = ...@@ -38,8 +38,10 @@ type qualid =
| Qident of ident | Qident of ident
| Qdot of qualid * ident | Qdot of qualid * ident
type opacity = bool
type pty = type pty =
| PPTtyvar of ident | PPTtyvar of ident * opacity
| PPTtyapp of qualid * pty list | PPTtyapp of qualid * pty list
| PPTtuple of pty list | PPTtuple of pty list
......
This diff is collapsed.
...@@ -21,7 +21,7 @@ open Mlw_expr ...@@ -21,7 +21,7 @@ open Mlw_expr
type dity = type dity =
| Dvar of dvar ref | Dvar of dvar ref
| Duvar of tvsymbol | Duvar of tvsymbol * (* opaque *) bool
| Dits of itysymbol * dity list * dreg list | Dits of itysymbol * dity list * dreg list
| Dts of tysymbol * dity list | Dts of tysymbol * dity list
...@@ -42,7 +42,7 @@ let ity_of_dity dity = ...@@ -42,7 +42,7 @@ let ity_of_dity dity =
| Dvar { contents = Dtvs _ } -> | Dvar { contents = Dtvs _ } ->
Loc.errorm "undefined type variable" Loc.errorm "undefined type variable"
| Dvar { contents = Dval dty } -> get_ity dty | Dvar { contents = Dval dty } -> get_ity dty
| Duvar tv -> ity_var tv | Duvar (tv,_) -> ity_var tv
| Dits (its,dl,rl) -> | Dits (its,dl,rl) ->
ity_app its (List.map get_ity dl) (List.map get_reg 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) | Dts (ts,dl) -> ity_pur ts (List.map get_ity dl)
...@@ -53,8 +53,8 @@ let ity_of_dity dity = ...@@ -53,8 +53,8 @@ let ity_of_dity dity =
in in
get_ity dity get_ity dity
let create_user_type_variable x = let create_user_type_variable x op =
Duvar (Typing.create_user_tv x.id) Duvar (Typing.create_user_tv x.id, op)
let create_type_variable () = let create_type_variable () =
Dvar (ref (Dtvs (create_tvsymbol (id_fresh "a")))) Dvar (ref (Dtvs (create_tvsymbol (id_fresh "a"))))
...@@ -118,12 +118,19 @@ let rec dity_refresh = function ...@@ -118,12 +118,19 @@ let rec dity_refresh = function
| Dits (its,dl,_) -> its_app its (List.map dity_refresh dl) | Dits (its,dl,_) -> its_app its (List.map dity_refresh dl)
| Dts (ts,dl) -> ts_app_real ts (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 *) (* unification *)
let rec occur_check tv = function let rec occur_check tv = function
| Dvar { contents = Dval d } -> occur_check tv d | Dvar { contents = Dval d } -> occur_check tv d
| Dits (_,dl,_) | Dts (_,dl) -> List.iter (occur_check tv) dl | 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 if tv_equal tv tv' then raise Exit
let rec occur_check_reg tv = function let rec occur_check_reg tv = function
...@@ -152,7 +159,7 @@ let rec unify ~weak d1 d2 = match d1,d2 with ...@@ -152,7 +159,7 @@ let rec unify ~weak d1 d2 = match d1,d2 with
| Dvar ({ contents = Dtvs tv } as r), d | Dvar ({ contents = Dtvs tv } as r), d
| d, Dvar ({ contents = Dtvs tv } as r) -> | d, Dvar ({ contents = Dtvs tv } as r) ->
occur_check tv d; r := Dval d 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 -> | Dits (its1, dl1, rl1), Dits (its2, dl2, rl2) when its_equal its1 its2 ->
assert (List.length rl1 = List.length rl2); assert (List.length rl1 = List.length rl2);
assert (List.length dl1 = List.length dl2); assert (List.length dl1 = List.length dl2);
...@@ -237,7 +244,7 @@ let specialize_scheme tvs (argl,res) = ...@@ -237,7 +244,7 @@ let specialize_scheme tvs (argl,res) =
let hreg = Htv.create 17 in let hreg = Htv.create 17 in
let rec specialize = function let rec specialize = function
| Dvar { contents = Dval d } -> specialize d | 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 if tv_in_tvars tv tvs then d else
begin try Htv.find htvs tv with Not_found -> begin try Htv.find htvs tv with Not_found ->
let v = create_type_variable () in let v = create_type_variable () in
...@@ -341,7 +348,7 @@ let print_dity fmt dity = ...@@ -341,7 +348,7 @@ let print_dity fmt dity =
let protect_on x s = if x then "(" ^^ s ^^ ")" else s in let protect_on x s = if x then "(" ^^ s ^^ ")" else s in
let rec print_dity inn fmt = function let rec print_dity inn fmt = function
| Dvar { contents = Dtvs tv } | Dvar { contents = Dtvs tv }
| Duvar tv -> | Duvar (tv,_) ->
Pretty.print_tv fmt tv Pretty.print_tv fmt tv
| Dvar { contents = Dval dty } -> | Dvar { contents = Dval dty } ->
print_dity inn fmt dty print_dity inn fmt dty
......
...@@ -30,12 +30,14 @@ val add_dvty: tvars -> dvty -> tvars ...@@ -30,12 +30,14 @@ val add_dvty: tvars -> dvty -> tvars
val add_dvty_vars: tvars -> dvty -> tvars (* add only variables *) val add_dvty_vars: tvars -> dvty -> tvars (* add only variables *)
val create_type_variable: unit -> dity 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 its_app: itysymbol -> dity list -> dity
val ts_app: tysymbol -> dity list -> dity val ts_app: tysymbol -> dity list -> dity
val dity_refresh: dity -> dity (* refresh regions *) 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 *) val is_chainable: dvty -> bool (* non-bool * non-bool -> bool *)
exception DTypeMismatch of dity * dity exception DTypeMismatch of dity * dity
......
...@@ -53,7 +53,10 @@ let create_plsymbol ?(hidden=false) ?(rdonly=false) id args value = ...@@ -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; Opt.iter (fun r -> ity_equal_check fd.fd_ity r.reg_ity) fd.fd_mut;
ty_of_ity fd.fd_ity in ty_of_ity fd.fd_ity in
let pure_args = List.map ty_of_field args 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 create_plsymbol_unsafe ls args value ~hidden ~rdonly
let ity_of_ty_opt ty = ity_of_ty (Opt.get_def ty_bool ty) 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 = ...@@ -571,11 +574,12 @@ let e_plapp pls el ity =
if pls.pl_rdonly then raise (RdOnlyPLS pls); if pls.pl_rdonly then raise (RdOnlyPLS pls);
let rec app tl varm ghost eff sbs fdl argl = match fdl, argl with 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 let mut_fold fn leff fd = Opt.fold fn leff fd.fd_mut in
| Some r -> fn eff (reg_full_inst sbs r) let leff = mut_fold (eff_read ~ghost) eff_empty pls.pl_value in
| None -> eff in let leff = List.fold_left (mut_fold eff_reset) leff pls.pl_args in
let eff = List.fold_left (mut_fold eff_reset) eff pls.pl_args in let mtv = Mtv.set_diff sbs.ity_subst_tv pls.pl_ls.ls_opaque in
let eff = mut_fold (eff_read ~ghost) eff pls.pl_value 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 let t = match pls.pl_ls.ls_value with
| Some _ -> fs_app pls.pl_ls tl (ty_of_ity ity) | Some _ -> fs_app pls.pl_ls tl (ty_of_ity ity)
| None -> ps_app pls.pl_ls tl in | None -> ps_app pls.pl_ls tl in
......
...@@ -456,6 +456,9 @@ let () = Exn_printer.register ...@@ -456,6 +456,9 @@ let () = Exn_printer.register
fprintf fmt "The type of exception %s has mutable components" id.id_string fprintf fmt "The type of exception %s has mutable components" id.id_string
| Mlw_ty.IllegalAlias _reg -> | Mlw_ty.IllegalAlias _reg ->