diff --git a/model_with_structures/analyzer.ml b/model_with_structures/analyzer.ml index 0d3c5c3..f7c3759 100644 --- a/model_with_structures/analyzer.ml +++ b/model_with_structures/analyzer.ml @@ -237,8 +237,6 @@ struct (* - value update *) - (* TODO: change and modify are different *) - let rec valchange (mem : mem) (v : value) (p : revpath) (b : value) : mem * value = match p, v with | VarRP, _ -> (mem, b) | DerefRP p, RefV id -> let (mem', v') = valchange mem (mem_get mem id) p b in @@ -336,7 +334,6 @@ struct (* - call values spoil *) (* TODO: check assignment type matches types separately later ?? *) - (* TODO: check all cases *) let is_correct_tags (r : read_cap) (w : write_cap) (m : mode) (c : copy_cap) : bool = (snd m != Out || c == Rf) && @@ -509,7 +506,7 @@ struct | TupleT _ -> raise @@ Eval_error "write: tuple type" | _ -> raise @@ Eval_error "write: type") | ReadS p -> (match pathtype types p with - | UnitT (r, _) -> + | UnitT (_, _) -> (* NOTE: not required *) (* if r == NRd *) (* then raise @@ Eval_error "read: not read tag" *) diff --git a/model_with_structures/synthesizer.ml b/model_with_structures/synthesizer.ml index 57b4207..2c0382c 100644 --- a/model_with_structures/synthesizer.ml +++ b/model_with_structures/synthesizer.ml @@ -164,12 +164,44 @@ struct (* NOTE: deepvalue - not used (?) *) + module MemVal = struct + [@@@warning "-26-27-32-33-34-35-36-37-38-39-60-66-67"] + [%%ocanren_inject + type nonrec t = ZeroMV | SmthMV | BotMV + [@@deriving gt ~options:{ show; gmap }] + type ground = t + ] + end + + module ReadVal = struct + [@@@warning "-26-27-32-33-34-35-36-37-38-39-60-66-67"] + [%%ocanren_inject + type nonrec t = ZeroRV | OneRV | TopRV + [@@deriving gt ~options:{ show; gmap }] + type ground = t + ] + end + + module WriteVal = struct + [@@@warning "-26-27-32-33-34-35-36-37-38-39-60-66-67"] + [%%ocanren_inject + type nonrec t = ZeroWV | SmthWV | OneWV + [@@deriving gt ~options:{ show; gmap }] + type ground = t + ] + end + module Value = struct [@@@warning "-26-27-32-33-34-35-36-37-38-39-60-66-67"] [%%ocanren_inject - type nonrec ('sl, 'd, 'vl) t = ZeroV | SmthV | BotV | FunV of 'sl | RefV of 'd | TupleV of 'vl + type nonrec ('vm, 'vr, 'vw, 'sl, 'd, 'vl) t = UnitV of 'vm * 'vr * 'vw + | FunV of 'sl + | RefV of 'd + | TupleV of 'vl [@@deriving gt ~options:{ show; gmap }] - type ground = (((* Nat.ground List.ground * *) Stmt.ground) List.ground, Nat.ground, ground List.ground) t + type ground = (MemVal.ground, ReadVal.ground, WriteVal.ground, + ((* Nat.ground List.ground * *) Stmt.ground) List.ground, + Nat.ground, ground List.ground) t ] end @@ -182,6 +214,15 @@ struct ] end + module Action = struct + [@@@warning "-26-27-32-33-34-35-36-37-38-39-60-66-67"] + [%%ocanren_inject + type nonrec t = ReadA | AlwaysWriteA | MayWriteA + [@@deriving gt ~options:{ show; gmap }] + type ground = t + ] + end + (* --- *) module MemEnv = struct @@ -340,6 +381,17 @@ struct { xs == [] & ys == [] & zs == [] } } + (* NOTE: unrequired ? *) + (* let list_map2o f xs ys zs = ocanren { *) + (* { xs == [] & ys == [] } | *) + (* { fresh x', xs', y', ys', z', zs' in *) + (* xs == x' :: xs' & *) + (* ys == y' :: ys' & *) + (* f x' y' z' *) + (* mapo f xs' ys' zs' & *) + (* zs == z' :: zs' } *) + (* } *) + (* - state utils *) let types_assoco id types tp = @@ -459,7 +511,8 @@ struct let is_trivial_vo v = let open Value in ocanren { - v == ZeroV | v == SmthV | v == BotV + fresh v_m, v_r, v_w in + v == UnitV (v_m, v_r, v_w) } let rec pathvaro p x = @@ -540,12 +593,19 @@ struct let open Value in let open ReadCap in let open CopyCap in + let open MemVal in + let open ReadVal in + let open WriteVal in ocanren { { fresh r, w in is_trivial_vo v & tp == UnitT (r, w) & - { { r == Rd & mem_with_id' == Std.pair mem v } | - { r == NRd & mem_with_id' == Std.pair mem BotV } } } | + { { fresh v_m, _v_r, _v_w in + r == Rd & + v == UnitV (v_m, _v_r, _v_w) & + mem_with_id' == Std.pair mem (UnitV (v_m, ZeroRV, ZeroWV)) } | + { r == NRd & + mem_with_id' == Std.pair mem (UnitV (BotMV, ZeroRV, ZeroWV)) } } } | { fresh stmts, ts in v == FunV stmts & tp == FunT ts & @@ -567,10 +627,43 @@ struct mem_with_id' == Std.pair mem' (TupleV vs') } } + (* - action rules *) + + let memvmodo a v_m v_m' = + let open MemVal in + let open Action in + ocanren { + { a == ReadA & v_m == ZeroMV & v_m' == ZeroMV } | + { a == AlwaysWriteA & v_m' == ZeroMV } | + { a == MayWriteA & v_m == ZeroMV & v_m' == ZeroMV } | + { a == MayWriteA & v_m =/= ZeroMV & v_m' == SmthMV } + } + + let readvmodo a v_r v_r' = + let open ReadVal in + let open Action in + ocanren { + { v_r == TopRV & v_r' == TopRV } | + { v_r == OneRV & v_r' == OneRV } | + { a == ReadA & v_r == ZeroRV & v_r' == OneRV } | + { a == AlwaysWriteA & v_r == ZeroRV & v_r' == TopRV } | + { a == MayWriteA & v_r == ZeroRV & v_r' == ZeroRV } + } + + let writevmodo a v_w v_w' = + let open WriteVal in + let open Action in + ocanren { + { a == ReadA & v_w' == v_w } | + { a == AlwaysWriteA & v_w' == OneWV } | + { a == MayWriteA & v_w == OneWV & v_w' == OneWV } | + { a == MayWriteA & v_w =/= OneWV & v_w' == v_w } + } + (* - value update *) (* NOTE: reversed path used *) - let rec valupdo mem v rp b mem_with_v' = + let rec valchangeo mem v rp b mem_with_v' = let open RevPath in let open Value in ocanren { @@ -580,7 +673,7 @@ struct rp == DerefRP rp' & v == RefV id & mem_geto mem id v' & - valupdo mem v' rp' b mem_with_v_upd & + valchangeo mem v' rp' b mem_with_v_upd & Std.pair mem_upd v_upd == mem_with_v_upd & mem_seto mem_upd id v_upd mem_st & mem_with_v' == Std.pair mem_st (RefV id) } | @@ -588,7 +681,40 @@ struct rp == AccessRP (rp', id) & v == TupleV vs' & list_ntho vs' id v' & - valupdo mem v' rp' b mem_with_v_upd & + valchangeo mem v' rp' b mem_with_v_upd & + Std.pair mem_upd v_upd == mem_with_v_upd & + list_replaceo vs' id v_upd vs_upd & + mem_with_v' == Std.pair mem_upd (TupleV vs_upd) } + } + + (* NOTE: reversed path used *) + let rec valupdo mem v rp a mem_with_v' = + let open RevPath in + let open Value in + ocanren { + { fresh v_m, v_r, v_w, + v_m', v_r', v_w', + v' in + rp == VarRP & + v == UnitV (v_m, v_r, v_w) & + memvmodo a v_m v_m' & + readvmodo a v_r v_r' & + writevmodo a v_w v_w' & + v' == UnitV (v_m', v_r', v_w') & + mem_with_v' == Std.pair mem v' } | + { fresh rp', id, v', mem_upd, v_upd, mem_with_v_upd, mem_st in + rp == DerefRP rp' & + v == RefV id & + mem_geto mem id v' & + valupdo mem v' rp' a mem_with_v_upd & + Std.pair mem_upd v_upd == mem_with_v_upd & + mem_seto mem_upd id v_upd mem_st & + mem_with_v' == Std.pair mem_st (RefV id) } | + { fresh rp', id, vs', v', mem_upd, v_upd, mem_with_v_upd, vs_upd in + rp == AccessRP (rp', id) & + v == TupleV vs' & + list_ntho vs' id v' & + valupdo mem v' rp' a mem_with_v_upd & Std.pair mem_upd v_upd == mem_with_v_upd & list_replaceo vs' id v_upd vs_upd & mem_with_v' == Std.pair mem_upd (TupleV vs_upd) } @@ -596,13 +722,50 @@ struct (* - value combination *) + let memvalcombo u v u' = + let open MemVal in + ocanren { + { u == ZeroMV & v == ZeroMV & u' == ZeroMV } | + { u == BotMV & v == BotMV & u' == BotMV } | + { u =/= ZeroMV & v =/= ZeroMV & + u =/= BotMV & v =/= BotMV & + u' == SmthMV } + } + + let readvalcombo u v u' = + let open ReadVal in + ocanren { + { u == TopRV & v == TopRV & u' == TopRV } | + { u == ZeroRV & v == ZeroRV & u' == ZeroRV } | + { u == TopRV & v == ZeroRV & u' == ZeroRV } | + { u == ZeroRV & v == TopRV & u' == ZeroRV } | + { u =/= TopRV & v =/= TopRV & + u =/= ZeroRV & v =/= ZeroRV & + u' == OneRV } + } + + let writevalcombo u v u' = + let open WriteVal in + ocanren { + { u == OneWV & v == OneWV & u' == OneWV } | + { u == ZeroWV & v == ZeroWV & u' == ZeroWV } | + { u =/= ZeroWV & v =/= ZeroWV & + u =/= OneWV & v =/= OneWV & + u' == SmthWV } + } + let rec valcombo u v u' = let open Value in ocanren { - { is_trivial_vo u & - is_trivial_vo v & - (* TODO: do not use disequality constraint ? *) - { { u == v & u' == u } | { u =/= v & u' == BotV } } } | + { fresh u_m, u_r, u_w, + v_m, v_r, v_w, + u_m', u_r', u_w' in + u == UnitV (u_m, u_r, u_w) & + v == UnitV (v_m, v_r, v_w) & + memvalcombo u_m v_m u_m' & + readvalcombo u_r v_r u_r' & + writevalcombo u_w v_w u_w' & + u' == UnitV (u_m', u_r', u_w') } | { fresh ustmts, vstmts, ustmts' in u == FunV ustmts & v == FunV vstmts & @@ -642,8 +805,11 @@ struct exprvalo mem vals e v' = let open Expr in let open Value in + let open MemVal in + let open ReadVal in + let open WriteVal in ocanren { - { e == UnitE & v' == ZeroV } | + { e == UnitE & v' == UnitV (ZeroMV, ZeroRV, ZeroWV) } | { fresh p in e == PathE p & pathvalo mem vals p v' } | @@ -760,76 +926,99 @@ struct (* - call values spoil *) (* TODO: check that negation is interpreted correctly *) - let is_correct_tagso v r w _r' w' m c = - let open Value in + let is_correct_tagso r w m c = let open ReadCap in let open WriteCap in let open Mode in let open CopyCap in ocanren { - { r == NRd | r == Rd & v == ZeroV } & { r == NRd | r == Rd & is_ino m } & - { is_not_outo m | is_outo m & w == AlwaysWr } & - { w == NeverWr | - w =/= NeverWr & w' =/= AlwaysWr & is_not_outo m & c == Cp | - w =/= NeverWr & w' == AlwaysWr } & - is_trivial_vo v + { is_not_outo m | is_outo m & w == AlwaysWr & c == Rf } } - let rec valspoil_foldero m c mem_with_vs tp u v mem_with_vs' = ocanren { + let tryreado r v_m v_r v_w v' = + let open Action in + let open Value in + let open ReadCap in + ocanren { + { fresh v_m', v_r', v_w' in + r == Rd & + memvmodo ReadA v_m v_m' & + readvmodo ReadA v_r v_r' & + writevmodo ReadA v_w v_w' & + v' == UnitV (v_m', v_r', v_w') } | + { r == NRd & + v' == UnitV (v_m, v_r, v_w)} + } + + let tryspoilo m w v_m v_m' = + let open Mode in + let open WriteCap in + let open MemVal in + ocanren { + { is_outo m & { w == AlwaysWr | w == MayWr } & v_m' == v_m } | + { is_not_outo m & w == AlwaysWr & v_m' == BotMV } | + { is_not_outo m & w == MayWr & v_m' == SmthMV } + } + + let rec valspoil_foldero m c mem_with_vs tp v mem_with_vs' = ocanren { fresh mem, vs, mem', v' in Std.pair mem vs == mem_with_vs & - valspoilo mem v tp u m c (Std.pair mem' v') & + valspoilo mem v tp m c (Std.pair mem' v') & mem_with_vs' == Std.pair mem' (v' :: vs) } - and valspoilo mem v tp u m c mem_with_v' = + and valspoilo mem v tp m c mem_with_v' = let open Type in let open Value in let open Mode in let open WriteCap in let open CopyCap in + let open Action in ocanren { - { fresh r, w, r', w' in + { fresh r, w, + v_m, v_r, v_w, + v', v'' in tp == UnitT (r, w) & - u == UnitT (r', w') & - is_trivial_vo v & - is_correct_tagso v r w r' w' m c & + v == UnitV (v_m, v_r, v_w) & + is_correct_tagso r w m c & + tryreado r v_m v_r v_w v' & { - { is_not_outo m & - c == Rf & - { w == AlwaysWr | w == MayWr } & - mem_with_v' == Std.pair mem BotV } | - { is_outo m & - w == AlwaysWr & - mem_with_v' == Std.pair mem ZeroV } | - { { is_outo m | - is_not_outo m & c == Cp | - is_not_outo m & c == Rf & w == NeverWr } & - { is_not_outo m | - is_outo m & w == MayWr | - is_outo m & w == NeverWr } & - mem_with_v' == Std.pair mem v } + { c == Cp & w == NeverWr & + mem_with_v' == Std.pair mem v' } | + { fresh v_m', v_r', v_w', + v_m'', v_r'', v_w'', + v_m''' in + v' == UnitV (v_m', v_r', v_w') & + { + { w == AlwaysWr & + memvmodo AlwaysWriteA v_m' v_m'' & + readvmodo AlwaysWriteA v_r' v_r'' & + writevmodo AlwaysWriteA v_w' v_w'' } | + { w == MayWr & + memvmodo MayWriteA v_m' v_m'' & + readvmodo MayWriteA v_r' v_r'' & + writevmodo MayWriteA v_w' v_w'' } + } & + tryspoilo m w v_m'' v_m''' & + v'' == UnitV (v_m''', v_r'', v_w'') & + mem_with_v' == Std.pair mem v'' } } } | - { fresh ts, us, _stmts in + { fresh ts, _stmts in tp == FunT ts & - u == FunT us & v == FunV _stmts & - ts == us & mem_with_v' == Std.pair mem v } | - { fresh ctp', tp', cu', u', id', v', mem_sp, v_sp, mem_set in + { fresh ctp', tp', cu', id', v', mem_sp, v_sp, mem_set in tp == RefT (ctp', tp') & - u == RefT (cu', u') & v == RefV id' & mem_geto mem id' v' & - valspoilo mem v' tp' u' m ctp' (Std.pair mem_sp v_sp) & + valspoilo mem v' tp' m ctp' (Std.pair mem_sp v_sp) & mem_seto mem_sp id' v_sp mem_set & mem_with_v' == Std.pair mem_set (RefV id') } | { fresh tps, us, vs, mem_sp, vs_sp in tp == TupleT tps & - u == TupleT us & v == TupleV vs & - list_foldr3o (valspoil_foldero m c) - (Std.pair mem []) tps us vs + list_foldr2o (valspoil_foldero m c) + (Std.pair mem []) tps vs (Std.pair mem_sp vs_sp) & mem_with_v' == Std.pair mem_sp (TupleV vs_sp) } @@ -843,17 +1032,17 @@ struct let open RevPath in ocanren { fresh mem, types, vals, visited, - x, id, b, tp', rp, + x, id, b(* , tp' *), rp, mem_sp, b_sp, v_sp, mem_upd, v_upd in st == StEnv (mem, types, vals, visited) & pathvaro p x & vals_assoco x vals id & pathvalo mem vals p b & - pathtypeo types p tp' & + (* pathtypeo types p tp' & *) valspoilo mem b tp tp' m Cp (Std.pair mem_sp b_sp) & mem_geto mem_sp id v_sp & pathrevo p VarRP rp & - valupdo mem_sp v_sp rp b_sp (Std.pair mem_upd v_upd) & + valchangeo mem_sp v_sp rp b_sp (Std.pair mem_upd v_upd) & mem_seto mem_upd id v_upd mem' } @@ -910,8 +1099,45 @@ struct (* - function evaluation *) (* NOTE: not needed due to performed optimization in stmt_eval ? *) + let writeval_to_capo v_w w' = + let open WriteVal in + let open WriteCap in + ocanren { + { v_w == ZeroWV & w' == NeverWr } | + { v_w == SmthWV & w' == MayWr } | + { v_w == OneWV & w' == AlwaysWr } + } + + let rec tags_checko mem v tp = + let open ReadVal in + let open ReadCap in + let open Type in + let open Value in + ocanren { + { fresh v_m, v_r, v_w, + r, w in + v == unitV (v_m, v_r, v_w) & + tp == UnitT (r, w) & + { + { r == R & v_r == OneRV } | + { r == NRd & v_r == ZeroRV } | + { r == NRd & v_r == TopRV } + } & + writeval_to_vapo v_w w + } | + { fresh _stmts, _ts in + v == FunV _stmts & + tp == FunT _ts } | + { fresh id, _c, tp', v' in + v == RefV id & + tp == RefT (_c, tp') & + mem_geto mem id v' & + tags_checko mem v' tp' } | + { fresh vs, ts in + List.mapo (tags_checko mem) vs ts } + } + (* - statement evaluation *) - (* TODO *) let rec stmt_addarg_foldero vals st_with_id mtp e st_with_id' = ocanren { fresh st, x, m, tp, st' in @@ -920,16 +1146,26 @@ struct addargo st vals x tp e st' & st_with_id' == Std.pair st' (Nat.s x) } + and f_tags_check_foldero mem vals x mtp x' = ocanren { + fresh m, tp, id', v' in + mtp == Std.pair m tp & + vals_assoco x vals id' & + mem_geto mem id' v' & + tags_checko mem v' tp & + x' == Nat.s x + } and stmt_eval_func_foldero mem types vals visited stmt visited' = let open StEnv in ocanren { { fresh visited_add, st, - st', mem', types', vals' in + st', mem', types', vals', + _x' in not_visited_checko visited stmt & visited_addo visited stmt visited_add & st == StEnv (mem, types, vals, visited_add) & stmt_evalo st stmt st' & - st' == StEnv (mem', types', vals', visited') } | + st' == StEnv (mem', types', vals', visited') & + list_foldlo (f_tags_check_foldero mem' vals') 0 ts _x' } | { visited_checko visited stmt & visited == visited' } } @@ -950,6 +1186,7 @@ struct let open TypesEnv in let open ValsEnv in let open RevPath in + let open Action in ocanren { fresh mem, types, vals, visited in st == StEnv (mem, types, vals, visited) & @@ -995,13 +1232,25 @@ struct vals_assoco x vals id & mem_geto mem id v & pathrevo p VarRP rp & - valupdo mem v rp ZeroV (Std.pair mem_upd v_upd) & + valupdo mem v rp AlwaysWriteA (Std.pair mem_upd v_upd) & mem_seto mem_upd id v_upd mem_set & st' == StEnv (mem_set, types, vals, visited) } | - { fresh p in + { fresh p, tp, _r, _w, x, id, v, rp, + mem_upd, v_upd, mem_set in s == ReadS p & - pathvalo mem vals p ZeroV & - st == st' } | + pathtypeo types p tp & + tp == UnitT (_r, _w) & + pathvaro p x & + vals_assoco x vals id & + mem_geto mem id v & + pathrevo p VarRP rp & + valupdo mem v rp ReadA (Std.pair mem_upd v_upd) & + mem_seto mem_upd id v_upd mem_set & + st' == StEnv (mem_set, types, vals, visited) } | + (* { fresh p in *) + (* s == ReadS p & *) + (* pathvalo mem vals p ZeroV & *) + (* st == st' } | *) { fresh sl, sr, stl in s == SeqS (sl, sr) & stmt_evalo st sl stl &