diff --git a/bench/programs/bad-typing/alias1.mlw b/bench/programs/bad-typing/alias1.mlw index 43e8927f9e5b34d85402dfcebed03d1645f578b0..8136381f6e9869c9320f75d2154e9b7c9222a285 100644 --- a/bench/programs/bad-typing/alias1.mlw +++ b/bench/programs/bad-typing/alias1.mlw @@ -1,6 +1,6 @@ module M - use import module stdlib.Ref + use import module ref.Ref let foo (x : ref int) (y : ref int) = x := 1; diff --git a/bench/programs/bad-typing/alias2.mlw b/bench/programs/bad-typing/alias2.mlw index fd1db78bd384c832f8433907c913bfda1e818508..da5880a3fd84a0f35575cb71d76aedb4bf9eba64 100644 --- a/bench/programs/bad-typing/alias2.mlw +++ b/bench/programs/bad-typing/alias2.mlw @@ -1,6 +1,6 @@ module M - use import module stdlib.Ref + use import module ref.Ref let foo (x : ref int) (y : ref int) = x := 1; diff --git a/bench/programs/bad-typing/alias3.mlw b/bench/programs/bad-typing/alias3.mlw index d66cacbf48c83228787ffe8f9397cc439f8c05d0..767998ac5cfb43ce4095153c070b63ae60b40d91 100644 --- a/bench/programs/bad-typing/alias3.mlw +++ b/bench/programs/bad-typing/alias3.mlw @@ -1,6 +1,6 @@ module M - use import module stdlib.Ref + use import module ref.Ref let foo (x : ref int) (y : ref int) = x := 1; diff --git a/bench/programs/bad-typing/effect1.mlw b/bench/programs/bad-typing/effect1.mlw index 624e2100d309b4f4384ed7dab1f39f236fe6066d..4f4eba3fa35f68c133334301e07f1d2fdaf78f52 100644 --- a/bench/programs/bad-typing/effect1.mlw +++ b/bench/programs/bad-typing/effect1.mlw @@ -1,7 +1,7 @@ module M - use import module stdlib.Ref + use import module ref.Ref parameter f : x:int -> {} unit writes a.contents {} diff --git a/bench/programs/bad-typing/effect2.mlw b/bench/programs/bad-typing/effect2.mlw index 89610e5874829cc6979d71b2cf6fd5b958c72209..908da447efb23ab6f451c02297a9e6b093b44a23 100644 --- a/bench/programs/bad-typing/effect2.mlw +++ b/bench/programs/bad-typing/effect2.mlw @@ -1,7 +1,7 @@ module M - use import module stdlib.Ref + use import module ref.Ref parameter f : x:int -> {} unit writes x.contents {} diff --git a/bench/programs/bad-typing/effect3.mlw b/bench/programs/bad-typing/effect3.mlw index 8a189a1520da66d3e1e1d4c5d8ebe8db7bea9f5c..79a4b873a886877024db2870b30e43f773f1fe4f 100644 --- a/bench/programs/bad-typing/effect3.mlw +++ b/bench/programs/bad-typing/effect3.mlw @@ -1,7 +1,7 @@ module M - use import module stdlib.Ref + use import module ref.Ref parameter a : int diff --git a/bench/programs/bad-typing/effect4.mlw b/bench/programs/bad-typing/effect4.mlw index fde4c12250ce5042afd461f4fb035ffc1ba03023..c95456e24ba3fdd7ee453e7d7c210d3158065944 100644 --- a/bench/programs/bad-typing/effect4.mlw +++ b/bench/programs/bad-typing/effect4.mlw @@ -1,7 +1,7 @@ module M - use import module stdlib.Ref + use import module ref.Ref parameter foo : int -> int diff --git a/bench/programs/bad-typing/fresh1.mlw b/bench/programs/bad-typing/fresh1.mlw index 9a0d23afc087d68e4b40c94ee444e27783d9f3ab..9e6955859455189906f982b63b690cf7664c4e1b 100644 --- a/bench/programs/bad-typing/fresh1.mlw +++ b/bench/programs/bad-typing/fresh1.mlw @@ -1,7 +1,7 @@ module P - use import module stdlib.Ref + use import module ref.Ref - let f (a : ref int) = a + let f (a : ref int) = todo (* TODO *) end diff --git a/modules/ref.mlw b/modules/ref.mlw index 893ac111183053980f1269685714a8ce1dec216b..c74d39ac9a38cb67c242b8f2f4fbc01c5b2a0071 100644 --- a/modules/ref.mlw +++ b/modules/ref.mlw @@ -6,11 +6,14 @@ module Ref logic (!) (x: ref 'a) : 'a = x.contents - parameter ref : v:'a -> {} ref 'a { result = {| contents = v |} } + (* parameter ref : v:'a -> {} ref 'a { result = {| contents = v |} } *) + let ref (v: 'a) = {} {| contents = v |} { result = {| contents = v |} } - parameter (!) : r:ref 'a -> {} 'a reads r { result = !r } + (* parameter (!) : r:ref 'a -> {} 'a reads r { result = !r } *) + let (!) (r:ref 'a) = {} r.contents { result = !r } - parameter (:=) : r:ref 'a -> v:'a -> {} unit writes r { !r = v } + (* parameter (:=) : r:ref 'a -> v:'a -> {} unit writes r { !r = v } *) + let (:=) (r:ref 'a) (v:'a) = {} r.contents <- v { !r = v } end @@ -24,3 +27,9 @@ module Refint parameter decr : r:ref int -> {} unit writes r { !r = old !r - 1 } end + +(* +Local Variables: +compile-command: "unset LANG; make -C .. modules/ref" +End: +*) diff --git a/src/parser/parser.pre.mly b/src/parser/parser.pre.mly index d53ed3dcadc7362e7c0fb322864dc93a3742bc3e..a4b4379c0eb9216b526f1c5101bc889fb735eeab 100644 --- a/src/parser/parser.pre.mly +++ b/src/parser/parser.pre.mly @@ -1030,11 +1030,11 @@ expr: mk_expr (mk_apply_id { id = "notb"; id_lab = []; id_loc = floc () } [t]) } | expr LARROW expr { match $1.expr_desc with - | Eapply (e11, e12) -> begin match e11.expr_desc with - | Eident x -> - mk_expr (Eassign (e12, x, $3)) + | Eaccess (e1, x) -> + mk_expr (Eassign (e1, x, $3)) + | Eapply (e11, e12) -> begin match e11.expr_desc with | Eapply ({ expr_desc = Eident (Qident x) }, e11) - when x.id = mixfix "[]" -> + when x.id = mixfix "[]" -> mk_mixfix3 "[]<-" e11 e12 $3 | _ -> raise Parsing.Parse_error @@ -1132,7 +1132,7 @@ expr_dot: expr_sub: | expr_dot DOT lqualid_rich - { mk_expr (mk_apply (mk_expr_i 3 (Eident $3)) [$1]) } + { mk_expr (Eaccess ($1, $3)) } | LEFTPAR expr RIGHTPAR { $2 } | BEGIN expr END diff --git a/src/parser/ptree.ml b/src/parser/ptree.ml index dffb9dfcf1c28aa1d4d4475befab51814d804c0e..c64f9186c559fa7f9c779d837677efd305d3eed6 100644 --- a/src/parser/ptree.ml +++ b/src/parser/ptree.ml @@ -211,6 +211,7 @@ and expr_desc = | Eletrec of (ident * binder list * variant option * triple) list * expr | Etuple of expr list | Erecord of (qualid * expr) list + | Eaccess of expr * qualid | Eassign of expr * qualid * expr (* control *) | Esequence of expr * expr diff --git a/src/programs/TODO b/src/programs/TODO index 3e76cfab80aa18f0a8fee5d29db62392a7b98772..16143e45472b0a3c40b58cf8cf2480f8260bc187 100644 --- a/src/programs/TODO +++ b/src/programs/TODO @@ -1,12 +1,10 @@ -o pas de old dans les invariants +o freshness analysis -o e <- e +o no `old' in loop invariants o {| e with x1 = e1; ...; xn = en |} -o WP: update - o syntactic sugar for postcondition: { pat | q } stands for { let pat = result in q } @@ -36,4 +34,4 @@ o library - List - Map - - Set \ No newline at end of file + - Set diff --git a/src/programs/pgm_pretty.ml b/src/programs/pgm_pretty.ml index 05faa84cbf9d778dc4c432b82f9377e32ed38211..e298757de696295f0ed6b3d9b9a552a6a51b8d22 100644 --- a/src/programs/pgm_pretty.ml +++ b/src/programs/pgm_pretty.ml @@ -76,7 +76,7 @@ let rec print_expr fmt e = match e.expr_desc with fprintf fmt "absurd" and print_pv fmt v = - fprintf fmt "<@[%a : %a@]>" print_vs v.pv_effect print_ty v.pv_pure.vs_ty + fprintf fmt "<@[%a@]>" print_vsty v.pv_effect and print_triple fmt (p, e, q) = fprintf fmt "@[%a@ %a@ %a@]" print_pre p print_expr e print_post q diff --git a/src/programs/pgm_ttree.ml b/src/programs/pgm_ttree.ml index 79c4631bb69f50e60a3db5c25ac205aa67625d7a..2a13d51e3292a47a4a66dd8368eccfe1356bd6c4 100644 --- a/src/programs/pgm_ttree.ml +++ b/src/programs/pgm_ttree.ml @@ -111,6 +111,8 @@ and dexpr_desc = | DEfun of dubinder list * dtriple | DElet of ident * dexpr * dexpr | DEletrec of drecfun list * dexpr + | DEaccess of dexpr * Term.lsymbol * int option + | DEassign of dexpr * Term.lsymbol * int * dexpr | DEsequence of dexpr * dexpr | DEif of dexpr * dexpr * dexpr @@ -204,6 +206,7 @@ and iexpr_desc = | IEfun of ibinder list * itriple | IElet of ivsymbol * iexpr * iexpr | IEletrec of irecfun list * iexpr + | IEaccess of ivsymbol * Term.lsymbol * R.t option | IEif of iexpr * iexpr * iexpr | IEloop of loop_annotation * iexpr diff --git a/src/programs/pgm_types.ml b/src/programs/pgm_types.ml index 3dd9fb6dd51e7dbcc4426531ad74912376eed2bb..31ec732d96131ae0c314914ff25814003478a127 100644 --- a/src/programs/pgm_types.ml +++ b/src/programs/pgm_types.ml @@ -228,7 +228,6 @@ module rec T : sig | PSlogic type psymbol = { - (* ps_impure : lsymbol; *) ps_effect : lsymbol; ps_pure : lsymbol; ps_kind : psymbol_kind; @@ -352,7 +351,6 @@ end = struct | PSlogic type psymbol = { - (* ps_impure : lsymbol; *) ps_effect : lsymbol; ps_pure : lsymbol; ps_kind : psymbol_kind; diff --git a/src/programs/pgm_types.mli b/src/programs/pgm_types.mli index ebaec01543193e40f9a6d90a488932c4f0ff9f03..3233ed51e2202e0be69b51465d7ab2d0707059c3 100644 --- a/src/programs/pgm_types.mli +++ b/src/programs/pgm_types.mli @@ -129,7 +129,6 @@ module rec T : sig | PSlogic type psymbol = { - (* ps_impure : lsymbol; *) ps_effect : lsymbol; ps_pure : lsymbol; ps_kind : psymbol_kind; diff --git a/src/programs/pgm_typing.ml b/src/programs/pgm_typing.ml index 6c65b3ac857dff23dbcaad3d351147f2d5c32210..0980fcb7bd1fb7f94216f33786a61058599ba93c 100644 --- a/src/programs/pgm_typing.ml +++ b/src/programs/pgm_typing.ml @@ -59,6 +59,25 @@ let () = Exn_printer.register (fun fmt e -> match e with let id_result = "result" +(* Table of record mutable fields ******************************************) + +let mutable_fields = Hts.create 17 (* ts -> field:int -> region:int *) + +let declare_mutable_field ts i j = + Pgm_wp.declare_mutable_field ts i j; + let h = + try + Hts.find mutable_fields ts + with Not_found -> + let h = Hashtbl.create 17 in Hts.add mutable_fields ts h; h + in + Hashtbl.add h i j + +let mutable_field ts i = + Hashtbl.find (Hts.find mutable_fields ts) i +let is_mutable_field ts i = + Hashtbl.mem (Hts.find mutable_fields ts) i + (* phase 1: typing programs (using destructive type inference) **************) let dty_app (ts, tyl) = assert (ts.ts_def = None); tyapp (ts, tyl) @@ -135,6 +154,9 @@ let check_region_vars () = List.iter (fun h -> Htv.clear values; Htv.iter check h) !region_vars; region_vars := [] +let is_fresh_region r = + r.R.r_tv.tv_name.id_string = "fresh" + let rec specialize_ty ?(policy=Region_var) ~loc htv ty = match ty.ty_node with | Ty.Tyvar _ -> Denv.specialize_ty ~loc htv ty @@ -142,7 +164,7 @@ let rec specialize_ty ?(policy=Region_var) ~loc htv ty = match ty.ty_node with let n = (get_mtsymbol ts).mt_regions in let mk_region ty = match ty.ty_node with | Ty.Tyvar _ when policy = Region_ret -> - tyvar (Typing.create_user_type_var "rho") + tyvar (Typing.create_user_type_var "fresh") | Ty.Tyvar tv when policy = Region_var -> let v = Denv.find_type_var ~loc htv tv in push_region_var tv (v, loc); @@ -473,9 +495,56 @@ and dexpr_desc ~ghost env loc = function in let d = List.fold_left2 constructor d fl tyl in d.dexpr_desc, ty - | Ptree.Eassign _ -> - assert false (*TODO*) - + | Ptree.Eaccess (e1, q) -> + let e1 = dexpr ~ghost env e1 in + let x = Typing.string_list_of_qualid [] q in + let ls = + try ns_find_ls (get_namespace (impure_uc env.uc)) x + with Not_found -> errorm ~loc "unbound record field %a" print_qualid q + in + new_regions_vars (); + let ty2 = match specialize_lsymbol ~loc (Htv.create 17) ls with + | [ty1], Some ty2 -> expected_type e1 ty1; ty2 + | _ -> assert false + in + begin match Typing.is_projection (impure_uc env.uc) ls with + | Some (ts, _, i) -> + let mt = get_mtsymbol ts in + let j = + try Some (mutable_field mt.mt_effect i) with Not_found -> None + in + DEaccess (e1, ls, j), ty2 + | _ -> + errorm ~loc "unbound record field %a" print_qualid q + end + | Ptree.Eassign (e1, q, e2) -> + let e1 = dexpr ~ghost env e1 in + let e2 = dexpr ~ghost env e2 in + let x = Typing.string_list_of_qualid [] q in + let ls = + try ns_find_ls (get_namespace (impure_uc env.uc)) x + with Not_found -> errorm ~loc "unbound record field %a" print_qualid q + in + new_regions_vars (); + begin match specialize_lsymbol ~loc (Htv.create 17) ls with + | [ty1], Some ty2 -> + expected_type e1 ty1; + expected_type e2 ty2 + | _ -> + assert false + end; + begin match Typing.is_projection (impure_uc env.uc) ls with + | Some (ts, _, i) -> + let mt = get_mtsymbol ts in + let j = + try mutable_field mt.mt_effect i + with Not_found -> errorm ~loc "not a mutable field" + in + DEassign (e1, ls, j, e2), dty_unit env.uc + | None -> + errorm ~loc "unbound record field %a" print_qualid q + end + | Ptree.Esequence (e1, e2) -> let e1 = dexpr ~ghost env e1 in expected_type e1 (dty_unit env.uc); @@ -623,21 +692,6 @@ let region_type ts i = (* eprintf "%a@." print_mt_symbol mt; *) Hashtbl.find (Hts.find region_types ts) i -let mutable_fields = Hts.create 17 (* ts -> field:int -> region:int *) - -let declare_mutable_field ts i j = - Pgm_wp.declare_mutable_field ts i j; - let h = - try - Hts.find mutable_fields ts - with Not_found -> - let h = Hashtbl.create 17 in Hts.add mutable_fields ts h; h - in - Hashtbl.add h i j - -let mutable_field ts i = - Hashtbl.find (Hts.find mutable_fields ts) i - let regions_tyapp ts nregions tyl = let tymatch s tv ty = Ty.ty_match s (ty_var tv) ty in let s = List.fold_left2 tymatch Mtv.empty ts.ts_args tyl in @@ -1043,6 +1097,49 @@ and iexpr_desc gl env loc ty = function let env, dl = iletrec gl env dl in let e1 = iexpr gl env e1 in IEletrec (dl, e1) + | DEaccess (e1, ls, j) -> + let e1 = iexpr gl env e1 in + let x1 = create_ivsymbol (id_fresh "x") e1.iexpr_type in + let r = match e1.iexpr_type.ty_node, j with + | Ty.Tyapp (ts, tyl), Some j -> + let mt = get_mtsymbol ts in + let r = regions_tyapp mt.mt_effect mt.mt_regions tyl in + Some (List.nth r j) + | Ty.Tyapp _, None -> + None + | Ty.Tyvar _, _ -> + assert false + in + IElet (x1, e1, mk_iexpr loc ty ( + IEaccess (x1, ls, r))) + | DEassign (e1, ls, j, e2) -> + (* e1.f <- e2 is syntactic sugar for + let x1 = e1 in let x2 = e2 in any {} writes f { x1.f = x2 } *) + let e1 = iexpr gl env e1 in + let e2 = iexpr gl env e2 in + let x1 = create_ivsymbol (id_fresh "x") e1.iexpr_type in + let x2 = create_ivsymbol (id_fresh "x") e2.iexpr_type in + let r = match e1.iexpr_type.ty_node with + | Ty.Tyapp (ts, tyl) -> + let mt = get_mtsymbol ts in + let r = regions_tyapp mt.mt_effect mt.mt_regions tyl in + List.nth r j + | Ty.Tyvar _ -> + assert false + in + let ef = { ie_reads = []; ie_writes = [r]; ie_raises = [] } in + let q = + let ls = (get_psymbol ls).ps_pure in + t_equ (fs_app ls [t_var x1.i_pure] x2.i_pure.vs_ty) (t_var x2.i_pure) + in + let q = (create_vsymbol (id_fresh "result") ty, q), [] in + let c = { + ic_result_type = ITpure ty; ic_effect = ef; + ic_pre = t_true; ic_post = q } + in + IElet (x1, e1, mk_iexpr loc ty ( + IElet (x2, e2, mk_iexpr loc ty ( + IEany c)))) | DEsequence (e1, e2) -> let vs = create_ivsymbol (id_fresh "_") (ty_app (ts_tuple 0) []) in @@ -1432,14 +1529,21 @@ and expr_desc gl env loc ty = function let env, v = add_local env v e1.expr_type_v in let e2 = expr gl env e2 in let ef = E.union e1.expr_effect e2.expr_effect in - if Sreg.exists (fun r -> occur_type_v r e2.expr_type_v) v.pv_regions then + let s = Sreg.filter is_fresh_region v.pv_regions in + if Sreg.exists (fun r -> occur_type_v r e2.expr_type_v) s then errorm ~loc "local reference would escape its scope"; - let ef = E.remove v.pv_regions ef in + let ef = E.remove s ef in Elet (v, e1, e2), e2.expr_type_v, ef | IEletrec (dl, e1) -> let env, dl = letrec gl env dl in let e1 = expr gl env e1 in Eletrec (dl, e1), e1.expr_type_v, e1.expr_effect + | IEaccess (i, ls, r) -> + let ef = option_apply E.empty (fun r -> E.add_read r E.empty) r in + let ls = (get_psymbol ls).ps_pure in + let v = Mvs.find i.i_impure env in + let t = fs_app ls [t_var v.pv_pure] (purify ty) in + Elogic t, tpure ty, ef | IEif (e1, e2, e3) -> let e1 = expr gl env e1 in @@ -1698,7 +1802,7 @@ let type_expr gl e = let e = iexpr gl ienv e in let e = expr gl Mvs.empty e in check_region_vars (); - fresh_expr gl ~term:true Spv.empty e; + (* fresh_expr gl ~term:true Spv.empty e; *) e let type_type uc ty = @@ -2082,6 +2186,9 @@ let rec decl ~wp env penv ltm lmod uc = function let tyv = iutype_v uc (create_ienv denv) tyv in let tyv = type_v Mvs.empty tyv in if cannot_be_generalized tyv then errorm ~loc "cannot be generalized"; + if Debug.test_flag debug then + eprintf "@[--parameter %s-----@\n %a@]@." + id.id print_type_v tyv; let ps, uc = match tyv with | Tarrow _ -> let ps, uc = add_global_fun loc id.id tyv uc in diff --git a/tests/test-pgm-jcf.mlw b/tests/test-pgm-jcf.mlw index 3cf1f6af249293682452cae3c3491c98f02bfed4..0b56318677763d45b3bb66becefd59cf038f453d 100644 --- a/tests/test-pgm-jcf.mlw +++ b/tests/test-pgm-jcf.mlw @@ -1,12 +1,18 @@ + module M - use import int.Int - use import module array.Array + use import module ref.Ref + + let test (x: ref int) = + { !x = 0 } + !x + { result = 0 } - let foo (a: array int) = - { 1 <= a.length } - a[0] <- 1 - { a[0] = 1 } + (* BUG *) + (* + let foo (a: ref int) = let x = a in fun () -> {} x := 0 { !x = 0 } + let test () = let x = ref 0 in begin foo x (); assert { !x = 0 } end + *) end