From 8bc864615eb8dccfe57f4c783beca82ae2586d5a Mon Sep 17 00:00:00 2001 From: Son Ho Date: Tue, 4 Jan 2022 21:41:11 +0100 Subject: Implement check_borrowed_values_invariant and fix minor issues --- src/Invariants.ml | 87 +++++++++++++++++++++++++++++++++++++++++++++++++++---- 1 file changed, 82 insertions(+), 5 deletions(-) (limited to 'src') diff --git a/src/Invariants.ml b/src/Invariants.ml index de162b6a..08ae6b4a 100644 --- a/src/Invariants.ml +++ b/src/Invariants.ml @@ -31,6 +31,12 @@ type outer_borrow_info = { outer_shared : bool; (* true if the value is borrowed as shared *) } +let set_outer_mut (info : outer_borrow_info) : outer_borrow_info = + { info with outer_borrow = true } + +let set_outer_shared (_info : outer_borrow_info) : outer_borrow_info = + { outer_borrow = true; outer_shared = true } + let borrows_infos_to_string (infos : borrow_info V.BorrowId.Map.t) : string = let bindings = V.BorrowId.Map.bindings infos in let bindings = List.map (fun (_, info) -> show_borrow_info info) bindings in @@ -112,11 +118,11 @@ let check_loans_borrows_relation_invariant (ctx : C.eval_ctx) : unit = object inherit [_] C.iter_eval_ctx as super - method! visit_Var inside_abs binder v = + method! visit_Var _ binder v = let inside_abs = false in super#visit_Var inside_abs binder v - method! visit_Abs inside_abs abs = + method! visit_Abs _ abs = let inside_abs = true in super#visit_Abs inside_abs abs @@ -124,7 +130,7 @@ let check_loans_borrows_relation_invariant (ctx : C.eval_ctx) : unit = (* Register the loan *) let _ = match lc with - | V.SharedLoan (bids, tv) -> register_shared_loan inside_abs bids + | V.SharedLoan (bids, _) -> register_shared_loan inside_abs bids | V.MutLoan bid -> register_mut_loan inside_abs bid in (* Continue exploring *) @@ -237,7 +243,7 @@ let check_loans_borrows_relation_invariant (ctx : C.eval_ctx) : unit = ("\nAbout to check context invariant:\n" ^ eval_ctx_to_string ctx ^ "\n")); L.log#ldebug (lazy - ("\Borrows information:\n" + ("\nBorrows information:\n" ^ borrows_infos_to_string !borrows_infos ^ "\n"))); @@ -258,7 +264,78 @@ let check_loans_borrows_relation_invariant (ctx : C.eval_ctx) : unit = - borrows/loans can't contain ⊥ or inactivated mut borrows - shared loans can't contain mutable loans *) -let check_borrowed_values_invariant (ctx : C.eval_ctx) : unit = () +let check_borrowed_values_invariant (ctx : C.eval_ctx) : unit = + let visitor = + object + inherit [_] C.iter_eval_ctx as super + + method! visit_Bottom info = + (* No ⊥ inside borrowed values *) + assert (not info.outer_borrow) + + method! visit_ABottom _info = + (* ⊥ inside an abstraction is not the same as in a regular value *) + () + + method! visit_loan_content info lc = + (* Update the info *) + let info = + match lc with + | V.SharedLoan (_, _) -> set_outer_shared info + | V.MutLoan _ -> + (* No mutable loan inside a shared loan *) + assert (not info.outer_shared); + set_outer_mut info + in + (* Continue exploring *) + super#visit_loan_content info lc + + method! visit_borrow_content info bc = + (* Update the info *) + let info = + match bc with + | V.SharedBorrow _ -> set_outer_shared info + | V.InactivatedMutBorrow _ -> + assert (not info.outer_borrow); + set_outer_shared info + | V.MutBorrow (_, _) -> set_outer_mut info + in + (* Continue exploring *) + super#visit_borrow_content info bc + + method! visit_aloan_content info lc = + (* Update the info *) + let info = + match lc with + | V.AMutLoan (_, _) -> set_outer_mut info + | V.ASharedLoan (_, _, _) -> set_outer_shared info + | V.AEndedMutLoan { given_back = _; child = _ } -> set_outer_mut info + | V.AEndedSharedLoan (_, _) -> set_outer_shared info + | V.AIgnoredMutLoan (_, _) -> set_outer_mut info + | V.AEndedIgnoredMutLoan { given_back = _; child = _ } -> + set_outer_mut info + | V.AIgnoredSharedLoan _ -> set_outer_shared info + in + (* Continue exploring *) + super#visit_aloan_content info lc + + method! visit_aborrow_content info bc = + (* Update the info *) + let info = + match bc with + | V.AMutBorrow (_, _) -> set_outer_mut info + | V.ASharedBorrow _ -> set_outer_shared info + | V.AIgnoredMutBorrow _ -> set_outer_mut info + | V.AProjSharedBorrow _ -> set_outer_shared info + in + (* Continue exploring *) + super#visit_aborrow_content info bc + end + in + + (* Explore *) + let info = { outer_borrow = false; outer_shared = false } in + visitor#visit_eval_ctx info ctx let check_typing_invariant (ctx : C.eval_ctx) : unit = () -- cgit v1.2.3 From 1ccba902961e20c098fd02224915f74e08c594a6 Mon Sep 17 00:00:00 2001 From: Son Ho Date: Tue, 4 Jan 2022 22:10:08 +0100 Subject: Start working on check_typing_invariant --- src/Invariants.ml | 24 +++++++++++++++++++++++- 1 file changed, 23 insertions(+), 1 deletion(-) (limited to 'src') diff --git a/src/Invariants.ml b/src/Invariants.ml index b67fa3a2..0478459b 100644 --- a/src/Invariants.ml +++ b/src/Invariants.ml @@ -9,6 +9,7 @@ module Subst = Substitute module A = CfimAst module L = Logging open InterpreterUtils +open Errors let debug_invariants : bool ref = ref false @@ -333,7 +334,28 @@ let check_borrowed_values_invariant (ctx : C.eval_ctx) : unit = let info = { outer_borrow = false; outer_shared = false } in visitor#visit_eval_ctx info ctx -let check_typing_invariant (_ctx : C.eval_ctx) : unit = () +let check_typing_invariant (ctx : C.eval_ctx) : unit = + let visitor = + object + inherit [_] C.iter_eval_ctx as super + + method! visit_typed_value info tv = + (* Check this pair (value, type) *) + (match (tv.V.value, tv.V.ty) with + | V.Concrete cv, _ -> raise Unimplemented + | V.Adt av, _ -> raise Unimplemented + | V.Bottom, _ -> (* Nothing to check *) () + | V.Borrow bc, _ -> raise Unimplemented + | V.Loan lc, _ -> raise Unimplemented + | V.Symbolic spc, _ -> raise Unimplemented + | _ -> failwith "Inconsistent typing"); + (* Continue exploring to inspect the subterms *) + super#visit_typed_value info tv + + method! visit_typed_avalue info atv = raise Unimplemented + end + in + visitor#visit_eval_ctx () ctx let check_invariants (ctx : C.eval_ctx) : unit = check_loans_borrows_relation_invariant ctx; -- cgit v1.2.3 From e70b541f6c3b6fb29f9807258cc88b4d88178f6a Mon Sep 17 00:00:00 2001 From: Son Ho Date: Tue, 4 Jan 2022 22:13:20 +0100 Subject: Implement check_constant_value_type --- src/Invariants.ml | 10 ++++++++-- 1 file changed, 8 insertions(+), 2 deletions(-) (limited to 'src') diff --git a/src/Invariants.ml b/src/Invariants.ml index 0478459b..e1ba0b22 100644 --- a/src/Invariants.ml +++ b/src/Invariants.ml @@ -334,6 +334,12 @@ let check_borrowed_values_invariant (ctx : C.eval_ctx) : unit = let info = { outer_borrow = false; outer_shared = false } in visitor#visit_eval_ctx info ctx +let check_constant_value_type (cv : V.constant_value) (ty : T.ety) : unit = + match (cv, ty) with + | V.Scalar sv, T.Integer int_ty -> assert (sv.int_ty = int_ty) + | V.Bool _, T.Bool | V.Char _, T.Char | V.String _, T.Str -> () + | _ -> failwith "Erroneous typing" + let check_typing_invariant (ctx : C.eval_ctx) : unit = let visitor = object @@ -342,13 +348,13 @@ let check_typing_invariant (ctx : C.eval_ctx) : unit = method! visit_typed_value info tv = (* Check this pair (value, type) *) (match (tv.V.value, tv.V.ty) with - | V.Concrete cv, _ -> raise Unimplemented + | V.Concrete cv, ty -> check_constant_value_type cv ty | V.Adt av, _ -> raise Unimplemented | V.Bottom, _ -> (* Nothing to check *) () | V.Borrow bc, _ -> raise Unimplemented | V.Loan lc, _ -> raise Unimplemented | V.Symbolic spc, _ -> raise Unimplemented - | _ -> failwith "Inconsistent typing"); + | _ -> failwith "Erroneous typing"); (* Continue exploring to inspect the subterms *) super#visit_typed_value info tv -- cgit v1.2.3 From 84bd12c6d832f20529bbfa763ac1a2de3909d382 Mon Sep 17 00:00:00 2001 From: Son Ho Date: Tue, 4 Jan 2022 22:38:25 +0100 Subject: Make good progress on visit_typed_value for check_typing_invariant --- src/Invariants.ml | 59 +++++++++++++++++++++++++++++++++++++++++++++++++++---- 1 file changed, 55 insertions(+), 4 deletions(-) (limited to 'src') diff --git a/src/Invariants.ml b/src/Invariants.ml index e1ba0b22..03cafd60 100644 --- a/src/Invariants.ml +++ b/src/Invariants.ml @@ -346,14 +346,65 @@ let check_typing_invariant (ctx : C.eval_ctx) : unit = inherit [_] C.iter_eval_ctx as super method! visit_typed_value info tv = - (* Check this pair (value, type) *) + (* Check the current pair (value, type) *) (match (tv.V.value, tv.V.ty) with | V.Concrete cv, ty -> check_constant_value_type cv ty - | V.Adt av, _ -> raise Unimplemented + (* ADT case *) + | V.Adt av, T.Adt (T.AdtId def_id, regions, tys) -> + (* Retrieve the definition to check the variant id, the number of + * parameters, etc. *) + let def = T.TypeDefId.nth ctx.type_context def_id in + (* Check the number of parameters *) + assert (List.length regions = List.length def.region_params); + assert (List.length tys = List.length def.type_params); + (* Check that the variant id is consistent *) + (match (av.V.variant_id, def.T.kind) with + | Some variant_id, T.Enum variants -> + assert (T.VariantId.to_int variant_id < List.length variants) + | None, T.Struct _ -> () + | _ -> failwith "Erroneous typing"); + (* Check that the field types are correct *) + let field_types = + Subst.type_def_get_instantiated_field_etypes def av.V.variant_id + tys + in + let fields_with_types = + List.combine av.V.field_values field_types + in + List.iter + (fun ((v, ty) : V.typed_value * T.ety) -> assert (v.V.ty = ty)) + fields_with_types + (* Tuple case *) + | V.Adt av, T.Adt (T.Tuple, regions, tys) -> + assert (regions = []); + assert (av.V.variant_id = None); + (* Check that the fields have the proper values - and check that there + * are as many fields as field types at the same time *) + let fields_with_types = List.combine av.V.field_values tys in + List.iter + (fun ((v, ty) : V.typed_value * T.ety) -> assert (v.V.ty = ty)) + fields_with_types + (* Assumed type case *) + | V.Adt av, T.Adt (T.Assumed aty_id, regions, tys) -> ( + assert (av.V.variant_id = None); + match (aty_id, av.V.field_values, regions, tys) with + (* Box *) + | T.Box, [ boxed_value ], [], [ boxed_ty ] -> + assert (boxed_value.V.ty = boxed_ty) + | _ -> failwith "Erroneous type") | V.Bottom, _ -> (* Nothing to check *) () - | V.Borrow bc, _ -> raise Unimplemented + | V.Borrow bc, T.Ref (_, ref_ty, rkind) -> ( + match (bc, rkind) with + | V.SharedBorrow bid, T.Shared | V.InactivatedMutBorrow bid, T.Mut + -> + (* Lookup the borrowed value to check it has the proper type *) + raise Unimplemented + | V.MutBorrow (_, bv), T.Mut -> assert (bv.V.ty = ref_ty) + | _ -> failwith "Erroneous typing") | V.Loan lc, _ -> raise Unimplemented - | V.Symbolic spc, _ -> raise Unimplemented + | V.Symbolic spc, ty -> + let ty' = Subst.erase_regions spc.V.svalue.V.sv_ty in + assert (ty' = ty) | _ -> failwith "Erroneous typing"); (* Continue exploring to inspect the subterms *) super#visit_typed_value info tv -- cgit v1.2.3 From 02a1cd57fe3a36f042579a2d0e8c194e4d9a599a Mon Sep 17 00:00:00 2001 From: Son Ho Date: Tue, 4 Jan 2022 22:40:55 +0100 Subject: Finish implementing visit_typed_value for check_typing_invariant --- src/Invariants.ml | 9 ++++++--- 1 file changed, 6 insertions(+), 3 deletions(-) (limited to 'src') diff --git a/src/Invariants.ml b/src/Invariants.ml index 03cafd60..457c00ad 100644 --- a/src/Invariants.ml +++ b/src/Invariants.ml @@ -397,11 +397,14 @@ let check_typing_invariant (ctx : C.eval_ctx) : unit = match (bc, rkind) with | V.SharedBorrow bid, T.Shared | V.InactivatedMutBorrow bid, T.Mut -> - (* Lookup the borrowed value to check it has the proper type *) - raise Unimplemented + (* TODO: lookup the borrowed value to check it has the proper type *) + () | V.MutBorrow (_, bv), T.Mut -> assert (bv.V.ty = ref_ty) | _ -> failwith "Erroneous typing") - | V.Loan lc, _ -> raise Unimplemented + | V.Loan lc, ty -> ( + match lc with + | V.SharedLoan (_, sv) -> assert (sv.V.ty = ty) + | V.MutLoan _ -> ()) | V.Symbolic spc, ty -> let ty' = Subst.erase_regions spc.V.svalue.V.sv_ty in assert (ty' = ty) -- cgit v1.2.3 From 90bbb47dea8ae6626e8aad89e3d2606ea3508534 Mon Sep 17 00:00:00 2001 From: Son Ho Date: Tue, 4 Jan 2022 22:42:26 +0100 Subject: Move some functions from Interpreter to InterpreterUtils --- src/Interpreter.ml | 536 ------------------------------------------------ src/InterpreterUtils.ml | 536 ++++++++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 536 insertions(+), 536 deletions(-) (limited to 'src') diff --git a/src/Interpreter.ml b/src/Interpreter.ml index b105c97b..77bd8764 100644 --- a/src/Interpreter.ml +++ b/src/Interpreter.ml @@ -32,542 +32,6 @@ type eval_error = Panic type 'a eval_result = ('a, eval_error) result -(** TODO: move *) -let borrow_is_asb (bid : V.BorrowId.id) (asb : V.abstract_shared_borrow) : bool - = - match asb with - | V.AsbBorrow bid' -> bid' = bid - | V.AsbProjReborrows _ -> false - -(** TODO: move *) -let borrow_in_asb (bid : V.BorrowId.id) (asb : V.abstract_shared_borrows) : bool - = - List.exists (borrow_is_asb bid) asb - -(** TODO: move *) -let remove_borrow_from_asb (bid : V.BorrowId.id) - (asb : V.abstract_shared_borrows) : V.abstract_shared_borrows = - let removed = ref 0 in - let asb = - List.filter - (fun asb -> - if not (borrow_is_asb bid asb) then true - else ( - removed := !removed + 1; - false)) - asb - in - assert (!removed = 1); - asb - -(* TODO: cleanup this a bit, once we have a better understanding about what we need *) -type exploration_kind = { - enter_shared_loans : bool; - enter_mut_borrows : bool; - enter_abs : bool; - (** Note that if we allow to enter abs, we don't check whether we enter - mutable/shared loans or borrows: there are no use cases requiring - a finer control. *) -} -(** This record controls how some generic helper lookup/update - functions behave, by restraining the kind of therms they can enter. -*) - -let ek_all : exploration_kind = - { enter_shared_loans = true; enter_mut_borrows = true; enter_abs = true } - -(** We sometimes need to return a value whose type may vary depending on - whether we find it in a "concrete" value or an abstraction (ex.: loan - contents when we perform environment lookups by using borrow ids) *) -type ('a, 'b) concrete_or_abs = Concrete of 'a | Abstract of 'b - -type g_loan_content = (V.loan_content, V.aloan_content) concrete_or_abs -(** Generic loan content: concrete or abstract *) - -type g_borrow_content = (V.borrow_content, V.aborrow_content) concrete_or_abs -(** Generic borrow content: concrete or abstract *) - -type abs_or_var_id = AbsId of V.AbstractionId.id | VarId of V.VarId.id - -exception Found -(** Utility exception - - When looking for something while exploring a term, it can be easier to - just throw an exception to signal we found what we were looking for. - *) - -exception FoundBorrowContent of V.borrow_content -(** Utility exception *) - -exception FoundLoanContent of V.loan_content -(** Utility exception *) - -exception FoundABorrowContent of V.aborrow_content -(** Utility exception *) - -exception FoundGBorrowContent of g_borrow_content -(** Utility exception *) - -exception FoundGLoanContent of g_loan_content -(** Utility exception *) - -(** Check if a value contains a borrow *) -let borrows_in_value (v : V.typed_value) : bool = - let obj = - object - inherit [_] V.iter_typed_value - - method! visit_borrow_content _env _ = raise Found - end - in - (* We use exceptions *) - try - obj#visit_typed_value () v; - false - with Found -> true - -(** Check if a value contains inactivated mutable borrows *) -let inactivated_in_value (v : V.typed_value) : bool = - let obj = - object - inherit [_] V.iter_typed_value - - method! visit_InactivatedMutBorrow _env _ = raise Found - end - in - (* We use exceptions *) - try - obj#visit_typed_value () v; - false - with Found -> true - -(** Check if a value contains a loan *) -let loans_in_value (v : V.typed_value) : bool = - let obj = - object - inherit [_] V.iter_typed_value - - method! visit_loan_content _env _ = raise Found - end - in - (* We use exceptions *) - try - obj#visit_typed_value () v; - false - with Found -> true - -let symbolic_value_id_in_ctx (sv_id : V.SymbolicValueId.id) (ctx : C.eval_ctx) : - bool = - let obj = - object - inherit [_] C.iter_eval_ctx - - method! visit_Symbolic _ sv = - if sv.V.svalue.V.sv_id = sv_id then raise Found else () - - method! visit_ASymbolic _ aproj = - match aproj with - | AProjLoans sv | AProjBorrows (sv, _) -> - if sv.V.sv_id = sv_id then raise Found else () - - method! visit_abstract_shared_borrows _ asb = - let visit (asb : V.abstract_shared_borrow) : unit = - match asb with - | V.AsbBorrow _ -> () - | V.AsbProjReborrows (sv, _) -> - if sv.V.sv_id = sv_id then raise Found else () - in - List.iter visit asb - end - in - (* We use exceptions *) - try - obj#visit_eval_ctx () ctx; - false - with Found -> true - -(** Lookup a loan content. - - The loan is referred to by a borrow id. - - TODO: group abs_or_var_id and g_loan_content. - *) -let lookup_loan_opt (ek : exploration_kind) (l : V.BorrowId.id) - (ctx : C.eval_ctx) : (abs_or_var_id * g_loan_content) option = - (* We store here whether we are inside an abstraction or a value - note that we - * could also track that with the environment, it would probably be more idiomatic - * and cleaner *) - let abs_or_var : abs_or_var_id option ref = ref None in - - let obj = - object - inherit [_] C.iter_eval_ctx as super - - method! visit_borrow_content env bc = - match bc with - | V.SharedBorrow bid -> - (* Nothing specific to do *) - super#visit_SharedBorrow env bid - | V.InactivatedMutBorrow bid -> - (* Nothing specific to do *) - super#visit_InactivatedMutBorrow env bid - | V.MutBorrow (bid, mv) -> - (* Control the dive *) - if ek.enter_mut_borrows then super#visit_MutBorrow env bid mv - else () - - method! visit_loan_content env lc = - match lc with - | V.SharedLoan (bids, sv) -> - (* Check if this is the loan we are looking for, and control the dive *) - if V.BorrowId.Set.mem l bids then - raise (FoundGLoanContent (Concrete lc)) - else if ek.enter_shared_loans then - super#visit_SharedLoan env bids sv - else () - | V.MutLoan bid -> - (* Check if this is the loan we are looking for *) - if bid = l then raise (FoundGLoanContent (Concrete lc)) - else super#visit_MutLoan env bid - (** We reimplement [visit_Loan] (rather than the more precise functions - [visit_SharedLoan], etc.) on purpose: as we have an exhaustive match - below, we are more resilient to definition updates (the compiler - is our friend). - *) - - method! visit_aloan_content env lc = - match lc with - | V.AMutLoan (bid, av) -> - if bid = l then raise (FoundGLoanContent (Abstract lc)) - else super#visit_AMutLoan env bid av - | V.ASharedLoan (bids, v, av) -> - if V.BorrowId.Set.mem l bids then - raise (FoundGLoanContent (Abstract lc)) - else super#visit_ASharedLoan env bids v av - | V.AEndedMutLoan { given_back; child } -> - super#visit_AEndedMutLoan env given_back child - | V.AEndedSharedLoan (v, av) -> super#visit_AEndedSharedLoan env v av - | V.AIgnoredMutLoan (bid, av) -> super#visit_AIgnoredMutLoan env bid av - | V.AEndedIgnoredMutLoan { given_back; child } -> - super#visit_AEndedIgnoredMutLoan env given_back child - | V.AIgnoredSharedLoan av -> super#visit_AIgnoredSharedLoan env av - (** Note that we don't control diving inside the abstractions: if we - allow to dive inside abstractions, we allow to go anywhere - (because there are no use cases requiring finer control) *) - - method! visit_Var env bv v = - assert (Option.is_none !abs_or_var); - abs_or_var := Some (VarId bv.C.index); - super#visit_Var env bv v; - abs_or_var := None - - method! visit_Abs env abs = - assert (Option.is_none !abs_or_var); - if ek.enter_abs then ( - abs_or_var := Some (AbsId abs.V.abs_id); - super#visit_Abs env abs) - else () - end - in - (* We use exceptions *) - try - obj#visit_eval_ctx () ctx; - None - with FoundGLoanContent lc -> ( - match !abs_or_var with - | Some abs_or_var -> Some (abs_or_var, lc) - | None -> failwith "Inconsistent state") - -(** Lookup a loan content. - - The loan is referred to by a borrow id. - Raises an exception if no loan was found. - *) -let lookup_loan (ek : exploration_kind) (l : V.BorrowId.id) (ctx : C.eval_ctx) : - abs_or_var_id * g_loan_content = - match lookup_loan_opt ek l ctx with - | None -> failwith "Unreachable" - | Some res -> res - -(** Update a loan content. - - The loan is referred to by a borrow id. - - This is a helper function: it might break invariants. - *) -let update_loan (ek : exploration_kind) (l : V.BorrowId.id) - (nlc : V.loan_content) (ctx : C.eval_ctx) : C.eval_ctx = - (* We use a reference to check that we update exactly one loan: when updating - * inside values, we check we don't update more than one loan. Then, upon - * returning we check that we updated at least once. *) - let r = ref false in - let update () : V.loan_content = - assert (not !r); - r := true; - nlc - in - - let obj = - object - inherit [_] C.map_eval_ctx as super - - method! visit_borrow_content env bc = - match bc with - | V.SharedBorrow _ | V.InactivatedMutBorrow _ -> - (* Nothing specific to do *) - super#visit_borrow_content env bc - | V.MutBorrow (bid, mv) -> - (* Control the dive into mutable borrows *) - if ek.enter_mut_borrows then super#visit_MutBorrow env bid mv - else V.MutBorrow (bid, mv) - - method! visit_loan_content env lc = - match lc with - | V.SharedLoan (bids, sv) -> - (* Shared loan: check if this is the loan we are looking for, and - control the dive. *) - if V.BorrowId.Set.mem l bids then update () - else if ek.enter_shared_loans then - super#visit_SharedLoan env bids sv - else V.SharedLoan (bids, sv) - | V.MutLoan bid -> - (* Mut loan: checks if this is the loan we are looking for *) - if bid = l then update () else super#visit_MutLoan env bid - (** We reimplement [visit_loan_content] (rather than one of the sub- - functions) on purpose: exhaustive matches are good for maintenance *) - - method! visit_abs env abs = - if ek.enter_abs then super#visit_abs env abs else abs - (** Note that once inside the abstractions, we don't control diving - (there are no use cases requiring finer control). - Also, as we give back a [loan_content] (and not an [aloan_content]) - we don't need to do reimplement the visit functions for the values - inside the abstractions (rk.: there may be "concrete" values inside - abstractions, so there is a utility in diving inside). *) - end - in - - let ctx = obj#visit_eval_ctx () ctx in - (* Check that we updated at least one loan *) - assert !r; - ctx - -(** Update a abstraction loan content. - - The loan is referred to by a borrow id. - - This is a helper function: it might break invariants. - *) -let update_aloan (ek : exploration_kind) (l : V.BorrowId.id) - (nlc : V.aloan_content) (ctx : C.eval_ctx) : C.eval_ctx = - (* We use a reference to check that we update exactly one loan: when updating - * inside values, we check we don't update more than one loan. Then, upon - * returning we check that we updated at least once. *) - let r = ref false in - let update () : V.aloan_content = - assert (not !r); - r := true; - nlc - in - - let obj = - object - inherit [_] C.map_eval_ctx as super - - method! visit_aloan_content env lc = - match lc with - | V.AMutLoan (bid, av) -> - if bid = l then update () else super#visit_AMutLoan env bid av - | V.ASharedLoan (bids, v, av) -> - if V.BorrowId.Set.mem l bids then update () - else super#visit_ASharedLoan env bids v av - | V.AEndedMutLoan { given_back; child } -> - super#visit_AEndedMutLoan env given_back child - | V.AEndedSharedLoan (v, av) -> super#visit_AEndedSharedLoan env v av - | V.AIgnoredMutLoan (bid, av) -> super#visit_AIgnoredMutLoan env bid av - | V.AEndedIgnoredMutLoan { given_back; child } -> - super#visit_AEndedIgnoredMutLoan env given_back child - | V.AIgnoredSharedLoan av -> super#visit_AIgnoredSharedLoan env av - - method! visit_abs env abs = - if ek.enter_abs then super#visit_abs env abs else abs - (** Note that once inside the abstractions, we don't control diving - (there are no use cases requiring finer control). *) - end - in - - let ctx = obj#visit_eval_ctx () ctx in - (* Check that we updated at least one loan *) - assert !r; - ctx - -(** Lookup a borrow content from a borrow id. *) -let lookup_borrow_opt (ek : exploration_kind) (l : V.BorrowId.id) - (ctx : C.eval_ctx) : g_borrow_content option = - let obj = - object - inherit [_] C.iter_eval_ctx as super - - method! visit_borrow_content env bc = - match bc with - | V.MutBorrow (bid, mv) -> - (* Check the borrow id and control the dive *) - if bid = l then raise (FoundGBorrowContent (Concrete bc)) - else if ek.enter_mut_borrows then super#visit_MutBorrow env bid mv - else () - | V.SharedBorrow bid -> - (* Check the borrow id *) - if bid = l then raise (FoundGBorrowContent (Concrete bc)) else () - | V.InactivatedMutBorrow bid -> - (* Check the borrow id *) - if bid = l then raise (FoundGBorrowContent (Concrete bc)) else () - - method! visit_loan_content env lc = - match lc with - | V.MutLoan bid -> - (* Nothing special to do *) super#visit_MutLoan env bid - | V.SharedLoan (bids, sv) -> - (* Control the dive *) - if ek.enter_shared_loans then super#visit_SharedLoan env bids sv - else () - - method! visit_aborrow_content env bc = - match bc with - | V.AMutBorrow (bid, av) -> - if bid = l then raise (FoundGBorrowContent (Abstract bc)) - else super#visit_AMutBorrow env bid av - | V.ASharedBorrow bid -> - if bid = l then raise (FoundGBorrowContent (Abstract bc)) - else super#visit_ASharedBorrow env bid - | V.AIgnoredMutBorrow av -> super#visit_AIgnoredMutBorrow env av - | V.AProjSharedBorrow asb -> - if borrow_in_asb l asb then - raise (FoundGBorrowContent (Abstract bc)) - else () - - method! visit_abs env abs = - if ek.enter_abs then super#visit_abs env abs else () - end - in - (* We use exceptions *) - try - obj#visit_eval_ctx () ctx; - None - with FoundGBorrowContent lc -> Some lc - -(** Lookup a borrow content from a borrow id. - - Raise an exception if no loan was found -*) -let lookup_borrow (ek : exploration_kind) (l : V.BorrowId.id) (ctx : C.eval_ctx) - : g_borrow_content = - match lookup_borrow_opt ek l ctx with - | None -> failwith "Unreachable" - | Some lc -> lc - -(** Update a borrow content. - - The borrow is referred to by a borrow id. - - This is a helper function: it might break invariants. - *) -let update_borrow (ek : exploration_kind) (l : V.BorrowId.id) - (nbc : V.borrow_content) (ctx : C.eval_ctx) : C.eval_ctx = - (* We use a reference to check that we update exactly one borrow: when updating - * inside values, we check we don't update more than one borrow. Then, upon - * returning we check that we updated at least once. *) - let r = ref false in - let update () : V.borrow_content = - assert (not !r); - r := true; - nbc - in - - let obj = - object - inherit [_] C.map_eval_ctx as super - - method! visit_borrow_content env bc = - match bc with - | V.MutBorrow (bid, mv) -> - (* Check the id and control dive *) - if bid = l then update () - else if ek.enter_mut_borrows then super#visit_MutBorrow env bid mv - else V.MutBorrow (bid, mv) - | V.SharedBorrow bid -> - (* Check the id *) - if bid = l then update () else super#visit_SharedBorrow env bid - | V.InactivatedMutBorrow bid -> - (* Check the id *) - if bid = l then update () - else super#visit_InactivatedMutBorrow env bid - - method! visit_loan_content env lc = - match lc with - | V.SharedLoan (bids, sv) -> - (* Control the dive *) - if ek.enter_shared_loans then super#visit_SharedLoan env bids sv - else V.SharedLoan (bids, sv) - | V.MutLoan bid -> - (* Nothing specific to do *) - super#visit_MutLoan env bid - - method! visit_abs env abs = - if ek.enter_abs then super#visit_abs env abs else abs - end - in - - let ctx = obj#visit_eval_ctx () ctx in - (* Check that we updated at least one borrow *) - assert !r; - ctx - -(** Update an abstraction borrow content. - - The borrow is referred to by a borrow id. - - This is a helper function: it might break invariants. - *) -let update_aborrow (ek : exploration_kind) (l : V.BorrowId.id) (nv : V.avalue) - (ctx : C.eval_ctx) : C.eval_ctx = - (* We use a reference to check that we update exactly one borrow: when updating - * inside values, we check we don't update more than one borrow. Then, upon - * returning we check that we updated at least once. *) - let r = ref false in - let update () : V.avalue = - assert (not !r); - r := true; - nv - in - - let obj = - object - inherit [_] C.map_eval_ctx as super - - method! visit_ABorrow env bc = - match bc with - | V.AMutBorrow (bid, av) -> - if bid = l then update () - else V.ABorrow (super#visit_AMutBorrow env bid av) - | V.ASharedBorrow bid -> - if bid = l then update () - else V.ABorrow (super#visit_ASharedBorrow env bid) - | V.AIgnoredMutBorrow av -> - V.ABorrow (super#visit_AIgnoredMutBorrow env av) - | V.AProjSharedBorrow asb -> - if borrow_in_asb l asb then update () - else V.ABorrow (super#visit_AProjSharedBorrow env asb) - - method! visit_abs env abs = - if ek.enter_abs then super#visit_abs env abs else abs - end - in - - let ctx = obj#visit_eval_ctx () ctx in - (* Check that we updated at least one borrow *) - assert !r; - ctx - (** The following type identifies the relative position of expressions (in particular borrows) in other expressions. diff --git a/src/InterpreterUtils.ml b/src/InterpreterUtils.ml index 17e8abb4..9e891348 100644 --- a/src/InterpreterUtils.ml +++ b/src/InterpreterUtils.ml @@ -84,3 +84,539 @@ let mk_aproj_loans_from_proj_comp (sv : V.symbolic_proj_comp) : V.typed_avalue = let proj = V.AProjLoans sv.V.svalue in let value = V.ASymbolic proj in { V.value; ty } + +(** TODO: move *) +let borrow_is_asb (bid : V.BorrowId.id) (asb : V.abstract_shared_borrow) : bool + = + match asb with + | V.AsbBorrow bid' -> bid' = bid + | V.AsbProjReborrows _ -> false + +(** TODO: move *) +let borrow_in_asb (bid : V.BorrowId.id) (asb : V.abstract_shared_borrows) : bool + = + List.exists (borrow_is_asb bid) asb + +(** TODO: move *) +let remove_borrow_from_asb (bid : V.BorrowId.id) + (asb : V.abstract_shared_borrows) : V.abstract_shared_borrows = + let removed = ref 0 in + let asb = + List.filter + (fun asb -> + if not (borrow_is_asb bid asb) then true + else ( + removed := !removed + 1; + false)) + asb + in + assert (!removed = 1); + asb + +(* TODO: cleanup this a bit, once we have a better understanding about what we need *) +type exploration_kind = { + enter_shared_loans : bool; + enter_mut_borrows : bool; + enter_abs : bool; + (** Note that if we allow to enter abs, we don't check whether we enter + mutable/shared loans or borrows: there are no use cases requiring + a finer control. *) +} +(** This record controls how some generic helper lookup/update + functions behave, by restraining the kind of therms they can enter. +*) + +let ek_all : exploration_kind = + { enter_shared_loans = true; enter_mut_borrows = true; enter_abs = true } + +(** We sometimes need to return a value whose type may vary depending on + whether we find it in a "concrete" value or an abstraction (ex.: loan + contents when we perform environment lookups by using borrow ids) *) +type ('a, 'b) concrete_or_abs = Concrete of 'a | Abstract of 'b + +type g_loan_content = (V.loan_content, V.aloan_content) concrete_or_abs +(** Generic loan content: concrete or abstract *) + +type g_borrow_content = (V.borrow_content, V.aborrow_content) concrete_or_abs +(** Generic borrow content: concrete or abstract *) + +type abs_or_var_id = AbsId of V.AbstractionId.id | VarId of V.VarId.id + +exception Found +(** Utility exception + + When looking for something while exploring a term, it can be easier to + just throw an exception to signal we found what we were looking for. + *) + +exception FoundBorrowContent of V.borrow_content +(** Utility exception *) + +exception FoundLoanContent of V.loan_content +(** Utility exception *) + +exception FoundABorrowContent of V.aborrow_content +(** Utility exception *) + +exception FoundGBorrowContent of g_borrow_content +(** Utility exception *) + +exception FoundGLoanContent of g_loan_content +(** Utility exception *) + +(** Check if a value contains a borrow *) +let borrows_in_value (v : V.typed_value) : bool = + let obj = + object + inherit [_] V.iter_typed_value + + method! visit_borrow_content _env _ = raise Found + end + in + (* We use exceptions *) + try + obj#visit_typed_value () v; + false + with Found -> true + +(** Check if a value contains inactivated mutable borrows *) +let inactivated_in_value (v : V.typed_value) : bool = + let obj = + object + inherit [_] V.iter_typed_value + + method! visit_InactivatedMutBorrow _env _ = raise Found + end + in + (* We use exceptions *) + try + obj#visit_typed_value () v; + false + with Found -> true + +(** Check if a value contains a loan *) +let loans_in_value (v : V.typed_value) : bool = + let obj = + object + inherit [_] V.iter_typed_value + + method! visit_loan_content _env _ = raise Found + end + in + (* We use exceptions *) + try + obj#visit_typed_value () v; + false + with Found -> true + +let symbolic_value_id_in_ctx (sv_id : V.SymbolicValueId.id) (ctx : C.eval_ctx) : + bool = + let obj = + object + inherit [_] C.iter_eval_ctx + + method! visit_Symbolic _ sv = + if sv.V.svalue.V.sv_id = sv_id then raise Found else () + + method! visit_ASymbolic _ aproj = + match aproj with + | AProjLoans sv | AProjBorrows (sv, _) -> + if sv.V.sv_id = sv_id then raise Found else () + + method! visit_abstract_shared_borrows _ asb = + let visit (asb : V.abstract_shared_borrow) : unit = + match asb with + | V.AsbBorrow _ -> () + | V.AsbProjReborrows (sv, _) -> + if sv.V.sv_id = sv_id then raise Found else () + in + List.iter visit asb + end + in + (* We use exceptions *) + try + obj#visit_eval_ctx () ctx; + false + with Found -> true + +(** Lookup a loan content. + + The loan is referred to by a borrow id. + + TODO: group abs_or_var_id and g_loan_content. + *) +let lookup_loan_opt (ek : exploration_kind) (l : V.BorrowId.id) + (ctx : C.eval_ctx) : (abs_or_var_id * g_loan_content) option = + (* We store here whether we are inside an abstraction or a value - note that we + * could also track that with the environment, it would probably be more idiomatic + * and cleaner *) + let abs_or_var : abs_or_var_id option ref = ref None in + + let obj = + object + inherit [_] C.iter_eval_ctx as super + + method! visit_borrow_content env bc = + match bc with + | V.SharedBorrow bid -> + (* Nothing specific to do *) + super#visit_SharedBorrow env bid + | V.InactivatedMutBorrow bid -> + (* Nothing specific to do *) + super#visit_InactivatedMutBorrow env bid + | V.MutBorrow (bid, mv) -> + (* Control the dive *) + if ek.enter_mut_borrows then super#visit_MutBorrow env bid mv + else () + + method! visit_loan_content env lc = + match lc with + | V.SharedLoan (bids, sv) -> + (* Check if this is the loan we are looking for, and control the dive *) + if V.BorrowId.Set.mem l bids then + raise (FoundGLoanContent (Concrete lc)) + else if ek.enter_shared_loans then + super#visit_SharedLoan env bids sv + else () + | V.MutLoan bid -> + (* Check if this is the loan we are looking for *) + if bid = l then raise (FoundGLoanContent (Concrete lc)) + else super#visit_MutLoan env bid + (** We reimplement [visit_Loan] (rather than the more precise functions + [visit_SharedLoan], etc.) on purpose: as we have an exhaustive match + below, we are more resilient to definition updates (the compiler + is our friend). + *) + + method! visit_aloan_content env lc = + match lc with + | V.AMutLoan (bid, av) -> + if bid = l then raise (FoundGLoanContent (Abstract lc)) + else super#visit_AMutLoan env bid av + | V.ASharedLoan (bids, v, av) -> + if V.BorrowId.Set.mem l bids then + raise (FoundGLoanContent (Abstract lc)) + else super#visit_ASharedLoan env bids v av + | V.AEndedMutLoan { given_back; child } -> + super#visit_AEndedMutLoan env given_back child + | V.AEndedSharedLoan (v, av) -> super#visit_AEndedSharedLoan env v av + | V.AIgnoredMutLoan (bid, av) -> super#visit_AIgnoredMutLoan env bid av + | V.AEndedIgnoredMutLoan { given_back; child } -> + super#visit_AEndedIgnoredMutLoan env given_back child + | V.AIgnoredSharedLoan av -> super#visit_AIgnoredSharedLoan env av + (** Note that we don't control diving inside the abstractions: if we + allow to dive inside abstractions, we allow to go anywhere + (because there are no use cases requiring finer control) *) + + method! visit_Var env bv v = + assert (Option.is_none !abs_or_var); + abs_or_var := Some (VarId bv.C.index); + super#visit_Var env bv v; + abs_or_var := None + + method! visit_Abs env abs = + assert (Option.is_none !abs_or_var); + if ek.enter_abs then ( + abs_or_var := Some (AbsId abs.V.abs_id); + super#visit_Abs env abs) + else () + end + in + (* We use exceptions *) + try + obj#visit_eval_ctx () ctx; + None + with FoundGLoanContent lc -> ( + match !abs_or_var with + | Some abs_or_var -> Some (abs_or_var, lc) + | None -> failwith "Inconsistent state") + +(** Lookup a loan content. + + The loan is referred to by a borrow id. + Raises an exception if no loan was found. + *) +let lookup_loan (ek : exploration_kind) (l : V.BorrowId.id) (ctx : C.eval_ctx) : + abs_or_var_id * g_loan_content = + match lookup_loan_opt ek l ctx with + | None -> failwith "Unreachable" + | Some res -> res + +(** Update a loan content. + + The loan is referred to by a borrow id. + + This is a helper function: it might break invariants. + *) +let update_loan (ek : exploration_kind) (l : V.BorrowId.id) + (nlc : V.loan_content) (ctx : C.eval_ctx) : C.eval_ctx = + (* We use a reference to check that we update exactly one loan: when updating + * inside values, we check we don't update more than one loan. Then, upon + * returning we check that we updated at least once. *) + let r = ref false in + let update () : V.loan_content = + assert (not !r); + r := true; + nlc + in + + let obj = + object + inherit [_] C.map_eval_ctx as super + + method! visit_borrow_content env bc = + match bc with + | V.SharedBorrow _ | V.InactivatedMutBorrow _ -> + (* Nothing specific to do *) + super#visit_borrow_content env bc + | V.MutBorrow (bid, mv) -> + (* Control the dive into mutable borrows *) + if ek.enter_mut_borrows then super#visit_MutBorrow env bid mv + else V.MutBorrow (bid, mv) + + method! visit_loan_content env lc = + match lc with + | V.SharedLoan (bids, sv) -> + (* Shared loan: check if this is the loan we are looking for, and + control the dive. *) + if V.BorrowId.Set.mem l bids then update () + else if ek.enter_shared_loans then + super#visit_SharedLoan env bids sv + else V.SharedLoan (bids, sv) + | V.MutLoan bid -> + (* Mut loan: checks if this is the loan we are looking for *) + if bid = l then update () else super#visit_MutLoan env bid + (** We reimplement [visit_loan_content] (rather than one of the sub- + functions) on purpose: exhaustive matches are good for maintenance *) + + method! visit_abs env abs = + if ek.enter_abs then super#visit_abs env abs else abs + (** Note that once inside the abstractions, we don't control diving + (there are no use cases requiring finer control). + Also, as we give back a [loan_content] (and not an [aloan_content]) + we don't need to do reimplement the visit functions for the values + inside the abstractions (rk.: there may be "concrete" values inside + abstractions, so there is a utility in diving inside). *) + end + in + + let ctx = obj#visit_eval_ctx () ctx in + (* Check that we updated at least one loan *) + assert !r; + ctx + +(** Update a abstraction loan content. + + The loan is referred to by a borrow id. + + This is a helper function: it might break invariants. + *) +let update_aloan (ek : exploration_kind) (l : V.BorrowId.id) + (nlc : V.aloan_content) (ctx : C.eval_ctx) : C.eval_ctx = + (* We use a reference to check that we update exactly one loan: when updating + * inside values, we check we don't update more than one loan. Then, upon + * returning we check that we updated at least once. *) + let r = ref false in + let update () : V.aloan_content = + assert (not !r); + r := true; + nlc + in + + let obj = + object + inherit [_] C.map_eval_ctx as super + + method! visit_aloan_content env lc = + match lc with + | V.AMutLoan (bid, av) -> + if bid = l then update () else super#visit_AMutLoan env bid av + | V.ASharedLoan (bids, v, av) -> + if V.BorrowId.Set.mem l bids then update () + else super#visit_ASharedLoan env bids v av + | V.AEndedMutLoan { given_back; child } -> + super#visit_AEndedMutLoan env given_back child + | V.AEndedSharedLoan (v, av) -> super#visit_AEndedSharedLoan env v av + | V.AIgnoredMutLoan (bid, av) -> super#visit_AIgnoredMutLoan env bid av + | V.AEndedIgnoredMutLoan { given_back; child } -> + super#visit_AEndedIgnoredMutLoan env given_back child + | V.AIgnoredSharedLoan av -> super#visit_AIgnoredSharedLoan env av + + method! visit_abs env abs = + if ek.enter_abs then super#visit_abs env abs else abs + (** Note that once inside the abstractions, we don't control diving + (there are no use cases requiring finer control). *) + end + in + + let ctx = obj#visit_eval_ctx () ctx in + (* Check that we updated at least one loan *) + assert !r; + ctx + +(** Lookup a borrow content from a borrow id. *) +let lookup_borrow_opt (ek : exploration_kind) (l : V.BorrowId.id) + (ctx : C.eval_ctx) : g_borrow_content option = + let obj = + object + inherit [_] C.iter_eval_ctx as super + + method! visit_borrow_content env bc = + match bc with + | V.MutBorrow (bid, mv) -> + (* Check the borrow id and control the dive *) + if bid = l then raise (FoundGBorrowContent (Concrete bc)) + else if ek.enter_mut_borrows then super#visit_MutBorrow env bid mv + else () + | V.SharedBorrow bid -> + (* Check the borrow id *) + if bid = l then raise (FoundGBorrowContent (Concrete bc)) else () + | V.InactivatedMutBorrow bid -> + (* Check the borrow id *) + if bid = l then raise (FoundGBorrowContent (Concrete bc)) else () + + method! visit_loan_content env lc = + match lc with + | V.MutLoan bid -> + (* Nothing special to do *) super#visit_MutLoan env bid + | V.SharedLoan (bids, sv) -> + (* Control the dive *) + if ek.enter_shared_loans then super#visit_SharedLoan env bids sv + else () + + method! visit_aborrow_content env bc = + match bc with + | V.AMutBorrow (bid, av) -> + if bid = l then raise (FoundGBorrowContent (Abstract bc)) + else super#visit_AMutBorrow env bid av + | V.ASharedBorrow bid -> + if bid = l then raise (FoundGBorrowContent (Abstract bc)) + else super#visit_ASharedBorrow env bid + | V.AIgnoredMutBorrow av -> super#visit_AIgnoredMutBorrow env av + | V.AProjSharedBorrow asb -> + if borrow_in_asb l asb then + raise (FoundGBorrowContent (Abstract bc)) + else () + + method! visit_abs env abs = + if ek.enter_abs then super#visit_abs env abs else () + end + in + (* We use exceptions *) + try + obj#visit_eval_ctx () ctx; + None + with FoundGBorrowContent lc -> Some lc + +(** Lookup a borrow content from a borrow id. + + Raise an exception if no loan was found +*) +let lookup_borrow (ek : exploration_kind) (l : V.BorrowId.id) (ctx : C.eval_ctx) + : g_borrow_content = + match lookup_borrow_opt ek l ctx with + | None -> failwith "Unreachable" + | Some lc -> lc + +(** Update a borrow content. + + The borrow is referred to by a borrow id. + + This is a helper function: it might break invariants. + *) +let update_borrow (ek : exploration_kind) (l : V.BorrowId.id) + (nbc : V.borrow_content) (ctx : C.eval_ctx) : C.eval_ctx = + (* We use a reference to check that we update exactly one borrow: when updating + * inside values, we check we don't update more than one borrow. Then, upon + * returning we check that we updated at least once. *) + let r = ref false in + let update () : V.borrow_content = + assert (not !r); + r := true; + nbc + in + + let obj = + object + inherit [_] C.map_eval_ctx as super + + method! visit_borrow_content env bc = + match bc with + | V.MutBorrow (bid, mv) -> + (* Check the id and control dive *) + if bid = l then update () + else if ek.enter_mut_borrows then super#visit_MutBorrow env bid mv + else V.MutBorrow (bid, mv) + | V.SharedBorrow bid -> + (* Check the id *) + if bid = l then update () else super#visit_SharedBorrow env bid + | V.InactivatedMutBorrow bid -> + (* Check the id *) + if bid = l then update () + else super#visit_InactivatedMutBorrow env bid + + method! visit_loan_content env lc = + match lc with + | V.SharedLoan (bids, sv) -> + (* Control the dive *) + if ek.enter_shared_loans then super#visit_SharedLoan env bids sv + else V.SharedLoan (bids, sv) + | V.MutLoan bid -> + (* Nothing specific to do *) + super#visit_MutLoan env bid + + method! visit_abs env abs = + if ek.enter_abs then super#visit_abs env abs else abs + end + in + + let ctx = obj#visit_eval_ctx () ctx in + (* Check that we updated at least one borrow *) + assert !r; + ctx + +(** Update an abstraction borrow content. + + The borrow is referred to by a borrow id. + + This is a helper function: it might break invariants. + *) +let update_aborrow (ek : exploration_kind) (l : V.BorrowId.id) (nv : V.avalue) + (ctx : C.eval_ctx) : C.eval_ctx = + (* We use a reference to check that we update exactly one borrow: when updating + * inside values, we check we don't update more than one borrow. Then, upon + * returning we check that we updated at least once. *) + let r = ref false in + let update () : V.avalue = + assert (not !r); + r := true; + nv + in + + let obj = + object + inherit [_] C.map_eval_ctx as super + + method! visit_ABorrow env bc = + match bc with + | V.AMutBorrow (bid, av) -> + if bid = l then update () + else V.ABorrow (super#visit_AMutBorrow env bid av) + | V.ASharedBorrow bid -> + if bid = l then update () + else V.ABorrow (super#visit_ASharedBorrow env bid) + | V.AIgnoredMutBorrow av -> + V.ABorrow (super#visit_AIgnoredMutBorrow env av) + | V.AProjSharedBorrow asb -> + if borrow_in_asb l asb then update () + else V.ABorrow (super#visit_AProjSharedBorrow env asb) + + method! visit_abs env abs = + if ek.enter_abs then super#visit_abs env abs else abs + end + in + + let ctx = obj#visit_eval_ctx () ctx in + (* Check that we updated at least one borrow *) + assert !r; + ctx -- cgit v1.2.3 From 8235330fd8150b464213c0b55acf4b0a13d42728 Mon Sep 17 00:00:00 2001 From: Son Ho Date: Tue, 4 Jan 2022 22:52:27 +0100 Subject: Improve check_typing_invariant to lookup borrowed/shared values and check they have the proper type --- src/Invariants.ml | 25 ++++++++++++++++++++----- 1 file changed, 20 insertions(+), 5 deletions(-) (limited to 'src') diff --git a/src/Invariants.ml b/src/Invariants.ml index 457c00ad..b3fc4903 100644 --- a/src/Invariants.ml +++ b/src/Invariants.ml @@ -396,15 +396,30 @@ let check_typing_invariant (ctx : C.eval_ctx) : unit = | V.Borrow bc, T.Ref (_, ref_ty, rkind) -> ( match (bc, rkind) with | V.SharedBorrow bid, T.Shared | V.InactivatedMutBorrow bid, T.Mut - -> - (* TODO: lookup the borrowed value to check it has the proper type *) - () - | V.MutBorrow (_, bv), T.Mut -> assert (bv.V.ty = ref_ty) + -> ( + (* Lookup the borrowed value to check it has the proper type *) + let _, glc = lookup_loan ek_all bid ctx in + match glc with + | Concrete (V.SharedLoan (_, sv)) + | Abstract (V.ASharedLoan (_, sv, _)) -> + assert (sv.V.ty = ref_ty) + | _ -> failwith "Inconsistent context") + | V.MutBorrow (bid, bv), T.Mut -> + assert ( + (* Check that the borrowed value has the proper type *) + bv.V.ty = ref_ty) | _ -> failwith "Erroneous typing") | V.Loan lc, ty -> ( match lc with | V.SharedLoan (_, sv) -> assert (sv.V.ty = ty) - | V.MutLoan _ -> ()) + | V.MutLoan bid -> ( + (* Lookup the borrowed value to check it has the proper type *) + let glc = lookup_borrow ek_all bid ctx in + match glc with + | Concrete (V.MutBorrow (_, bv)) -> assert (bv.V.ty = ty) + | Abstract (V.AMutBorrow (_, sv)) -> + assert (Subst.erase_regions sv.V.ty = ty) + | _ -> failwith "Inconsistent context")) | V.Symbolic spc, ty -> let ty' = Subst.erase_regions spc.V.svalue.V.sv_ty in assert (ty' = ty) -- cgit v1.2.3 From 7c0ef03a500702951866f9ae46b9043c2c24b4d4 Mon Sep 17 00:00:00 2001 From: Son Ho Date: Tue, 4 Jan 2022 23:03:15 +0100 Subject: Make good progress on visit_typed_avalue for check_typing_invariant --- src/Invariants.ml | 90 ++++++++++++++++++++++++++++++++++++++++++++++++++++++- 1 file changed, 89 insertions(+), 1 deletion(-) (limited to 'src') diff --git a/src/Invariants.ml b/src/Invariants.ml index b3fc4903..2cbae606 100644 --- a/src/Invariants.ml +++ b/src/Invariants.ml @@ -427,7 +427,95 @@ let check_typing_invariant (ctx : C.eval_ctx) : unit = (* Continue exploring to inspect the subterms *) super#visit_typed_value info tv - method! visit_typed_avalue info atv = raise Unimplemented + method! visit_typed_avalue info atv = + (* Check the current pair (value, type) *) + (match (atv.V.value, atv.V.ty) with + | V.AConcrete cv, ty -> + check_constant_value_type cv (Subst.erase_regions ty) + (* ADT case *) + | V.AAdt av, T.Adt (T.AdtId def_id, regions, tys) -> + (* Retrieve the definition to check the variant id, the number of + * parameters, etc. *) + let def = T.TypeDefId.nth ctx.type_context def_id in + (* Check the number of parameters *) + assert (List.length regions = List.length def.region_params); + assert (List.length tys = List.length def.type_params); + (* Check that the variant id is consistent *) + (match (av.V.variant_id, def.T.kind) with + | Some variant_id, T.Enum variants -> + assert (T.VariantId.to_int variant_id < List.length variants) + | None, T.Struct _ -> () + | _ -> failwith "Erroneous typing"); + (* Check that the field types are correct *) + let field_types = + Subst.type_def_get_instantiated_field_rtypes def av.V.variant_id + regions tys + in + let fields_with_types = + List.combine av.V.field_values field_types + in + List.iter + (fun ((v, ty) : V.typed_avalue * T.rty) -> assert (v.V.ty = ty)) + fields_with_types + (* Tuple case *) + | V.AAdt av, T.Adt (T.Tuple, regions, tys) -> + assert (regions = []); + assert (av.V.variant_id = None); + (* Check that the fields have the proper values - and check that there + * are as many fields as field types at the same time *) + let fields_with_types = List.combine av.V.field_values tys in + List.iter + (fun ((v, ty) : V.typed_avalue * T.rty) -> assert (v.V.ty = ty)) + fields_with_types + (* Assumed type case *) + | V.AAdt av, T.Adt (T.Assumed aty_id, regions, tys) -> ( + assert (av.V.variant_id = None); + match (aty_id, av.V.field_values, regions, tys) with + (* Box *) + | T.Box, [ boxed_value ], [], [ boxed_ty ] -> + assert (boxed_value.V.ty = boxed_ty) + | _ -> failwith "Erroneous type") + | V.ABottom, _ -> (* Nothing to check *) () + | V.ABorrow bc, T.Ref (_, ref_ty, rkind) -> ( + match (bc, rkind) with + | V.AMutBorrow (bid, av), T.Mut -> + (* Check that the child value has the proper type *) + assert (av.V.ty = ref_ty) + | V.ASharedBorrow bid, T.Shared -> ( + (* Lookup the borrowed value to check it has the proper type *) + let _, glc = lookup_loan ek_all bid ctx in + match glc with + | Concrete (V.SharedLoan (_, sv)) + | Abstract (V.ASharedLoan (_, sv, _)) -> + assert (sv.V.ty = Subst.erase_regions ref_ty) + | _ -> failwith "Inconsistent context") + | V.AIgnoredMutBorrow av, T.Mut -> assert (av.V.ty = ref_ty) + | V.AProjSharedBorrow _, T.Shared -> () + | _ -> failwith "Inconsistent context") + | V.ALoan lc, ty -> raise Unimplemented + (* ( + match lc with + | V.SharedLoan (_, sv) -> assert (sv.V.ty = ty) + | V.MutLoan bid -> ( + (* Lookup the borrowed value to check it has the proper type *) + let glc = lookup_borrow ek_all bid ctx in + match glc with + | Concrete (V.MutBorrow (_, bv)) -> assert (bv.V.ty = ty) + | Abstract (V.AMutBorrow (_, sv)) -> + assert (Subst.erase_regions sv.V.ty = ty) + | _ -> failwith "Inconsistent context"))*) + | V.ASymbolic aproj, ty -> + let ty1 = Subst.erase_regions ty in + let ty2 = + match aproj with + | V.AProjLoans sv | V.AProjBorrows (sv, _) -> + Subst.erase_regions sv.V.sv_ty + in + assert (ty1 = ty2) + | _ -> failwith "Erroneous typing"); + (* Continue exploring to inspect the subterms *) + super#visit_typed_avalue info atv + (** TODO: there is a lot of duplication with [visit_typed_value]... *) end in visitor#visit_eval_ctx () ctx -- cgit v1.2.3 From ab2637af8b82f13be8ac38a800368bce6bbd10e5 Mon Sep 17 00:00:00 2001 From: Son Ho Date: Tue, 4 Jan 2022 23:10:06 +0100 Subject: Finish implementing visit_typed_avalue for check_typing_invariant --- src/Invariants.ml | 36 ++++++++++++++++++++++++------------ 1 file changed, 24 insertions(+), 12 deletions(-) (limited to 'src') diff --git a/src/Invariants.ml b/src/Invariants.ml index 2cbae606..9390436c 100644 --- a/src/Invariants.ml +++ b/src/Invariants.ml @@ -492,18 +492,30 @@ let check_typing_invariant (ctx : C.eval_ctx) : unit = | V.AIgnoredMutBorrow av, T.Mut -> assert (av.V.ty = ref_ty) | V.AProjSharedBorrow _, T.Shared -> () | _ -> failwith "Inconsistent context") - | V.ALoan lc, ty -> raise Unimplemented - (* ( - match lc with - | V.SharedLoan (_, sv) -> assert (sv.V.ty = ty) - | V.MutLoan bid -> ( - (* Lookup the borrowed value to check it has the proper type *) - let glc = lookup_borrow ek_all bid ctx in - match glc with - | Concrete (V.MutBorrow (_, bv)) -> assert (bv.V.ty = ty) - | Abstract (V.AMutBorrow (_, sv)) -> - assert (Subst.erase_regions sv.V.ty = ty) - | _ -> failwith "Inconsistent context"))*) + | V.ALoan lc, aty -> ( + match lc with + | V.AMutLoan (bid, child_av) | V.AIgnoredMutLoan (bid, child_av) + -> ( + assert (child_av.V.ty = aty); + (* Lookup the borrowed value to check it has the proper type *) + let glc = lookup_borrow ek_all bid ctx in + match glc with + | Concrete (V.MutBorrow (_, bv)) -> + assert (bv.V.ty = Subst.erase_regions aty) + | Abstract (V.AMutBorrow (_, sv)) -> + assert ( + Subst.erase_regions sv.V.ty = Subst.erase_regions aty) + | _ -> failwith "Inconsistent context") + | V.ASharedLoan (_, sv, child_av) | V.AEndedSharedLoan (sv, child_av) + -> + let ty = Subst.erase_regions aty in + assert (sv.V.ty = ty); + assert (child_av.V.ty = aty) + | V.AEndedMutLoan { given_back; child } + | V.AEndedIgnoredMutLoan { given_back; child } -> + assert (given_back.V.ty = aty); + assert (child.V.ty = aty) + | V.AIgnoredSharedLoan child_av -> assert (child_av.V.ty = aty)) | V.ASymbolic aproj, ty -> let ty1 = Subst.erase_regions ty in let ty2 = -- cgit v1.2.3 From 1e83bc8b14c97170833a5af721e58ff746d61317 Mon Sep 17 00:00:00 2001 From: Son Ho Date: Tue, 4 Jan 2022 23:11:14 +0100 Subject: Cleanup a bit --- src/Invariants.ml | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) (limited to 'src') diff --git a/src/Invariants.ml b/src/Invariants.ml index 9390436c..fec6b2ed 100644 --- a/src/Invariants.ml +++ b/src/Invariants.ml @@ -9,7 +9,6 @@ module Subst = Substitute module A = CfimAst module L = Logging open InterpreterUtils -open Errors let debug_invariants : bool ref = ref false @@ -404,7 +403,7 @@ let check_typing_invariant (ctx : C.eval_ctx) : unit = | Abstract (V.ASharedLoan (_, sv, _)) -> assert (sv.V.ty = ref_ty) | _ -> failwith "Inconsistent context") - | V.MutBorrow (bid, bv), T.Mut -> + | V.MutBorrow (_, bv), T.Mut -> assert ( (* Check that the borrowed value has the proper type *) bv.V.ty = ref_ty) @@ -478,7 +477,7 @@ let check_typing_invariant (ctx : C.eval_ctx) : unit = | V.ABottom, _ -> (* Nothing to check *) () | V.ABorrow bc, T.Ref (_, ref_ty, rkind) -> ( match (bc, rkind) with - | V.AMutBorrow (bid, av), T.Mut -> + | V.AMutBorrow (_, av), T.Mut -> (* Check that the child value has the proper type *) assert (av.V.ty = ref_ty) | V.ASharedBorrow bid, T.Shared -> ( -- cgit v1.2.3 From 3114dea5e2155eeb52581952159107dfa239ccdc Mon Sep 17 00:00:00 2001 From: Son Ho Date: Wed, 5 Jan 2022 07:47:36 +0100 Subject: Start inserting calls to dummy synthesis functions in Interpreter.ml --- src/Interpreter.ml | 97 ++++++++++++++++++++++++++++++++++++++----------- src/InterpreterUtils.ml | 7 ++++ 2 files changed, 82 insertions(+), 22 deletions(-) (limited to 'src') diff --git a/src/Interpreter.ml b/src/Interpreter.ml index 77bd8764..e27aaaa8 100644 --- a/src/Interpreter.ml +++ b/src/Interpreter.ml @@ -11,6 +11,7 @@ open TypesUtils open ValuesUtils module Inv = Invariants open InterpreterUtils +module S = Synthesis (* TODO: check that the value types are correct when evaluating *) (* TODO: for debugging purposes, we might want to put use eval_ctx everywhere @@ -424,12 +425,6 @@ let rec apply_proj_borrows (check_symbolic_no_ended : bool) (ctx : C.eval_ctx) in { V.value; V.ty } -type symbolic_expansion = - | SeConcrete of V.constant_value - | SeAdt of (T.VariantId.id option * V.symbolic_proj_comp list) - | SeMutRef of V.BorrowId.id * V.symbolic_proj_comp - | SeSharedRef of V.BorrowId.set_t * V.symbolic_proj_comp - (** Convert a symbolic expansion *which is not a borrow* to a value *) let symbolic_expansion_non_borrow_to_value (sv : V.symbolic_value) (see : symbolic_expansion) : V.typed_value = @@ -2530,7 +2525,14 @@ let expand_symbolic_value_shared_borrow (config : C.config) let ctx, shared_sv = mk_fresh_symbolic_proj_comp ended_regions ref_ty ctx in let see = SeSharedRef (bids, shared_sv) in let allow_reborrows = true in - apply_symbolic_expansion_to_avalues config allow_reborrows original_sv see ctx + let ctx = + apply_symbolic_expansion_to_avalues config allow_reborrows original_sv see + ctx + in + (* Update the synthesized program *) + S.synthesize_symbolic_expansion original_sv see; + (* Return *) + ctx let expand_symbolic_value_borrow (config : C.config) (original_sv : V.symbolic_value) (ended_regions : T.RegionId.set_t) @@ -2555,8 +2557,14 @@ let expand_symbolic_value_borrow (config : C.config) in (* Expand the symbolic avalues *) let allow_reborrows = true in - apply_symbolic_expansion_to_avalues config allow_reborrows original_sv see - ctx + let ctx = + apply_symbolic_expansion_to_avalues config allow_reborrows original_sv + see ctx + in + (* Update the synthesized program *) + S.synthesize_symbolic_expansion original_sv see; + (* Return *) + ctx | T.Shared -> expand_symbolic_value_shared_borrow config original_sv ended_regions ref_ty ctx @@ -2569,7 +2577,8 @@ let expand_symbolic_value_non_enum (config : C.config) (pe : E.projection_elem) (sp : V.symbolic_proj_comp) (ctx : C.eval_ctx) : C.eval_ctx = (* Compute the expanded value - note that when doing so, we may introduce * fresh symbolic values in the context (which thus gets updated) *) - let rty = sp.V.svalue.V.sv_ty in + let original_sv = sp.V.svalue in + let rty = original_sv.V.sv_ty in let ended_regions = sp.V.rset_ended in let ctx = match (pe, rty) with @@ -2584,36 +2593,54 @@ let expand_symbolic_value_non_enum (config : C.config) (pe : E.projection_elem) compute_expanded_symbolic_adt_value expand_enumerations ended_regions def_id regions types ctx with - | [ (ctx, nv) ] -> + | [ (ctx, see) ] -> (* Apply in the context *) - apply_symbolic_expansion_non_borrow config sp.V.svalue nv ctx + let ctx = + apply_symbolic_expansion_non_borrow config original_sv see ctx + in + (* Update the synthesized program *) + S.synthesize_symbolic_expansion original_sv see; + (* Return *) + ctx | _ -> failwith "Unexpected") (* Tuples *) | Field (ProjTuple arity, _), T.Adt (T.Tuple, [], tys) -> assert (arity = List.length tys); (* Generate the field values *) - let ctx, nv = + let ctx, see = compute_expanded_symbolic_tuple_value ended_regions tys ctx in (* Apply in the context *) - apply_symbolic_expansion_non_borrow config sp.V.svalue nv ctx + let ctx = + apply_symbolic_expansion_non_borrow config original_sv see ctx + in + (* Update the synthesized program *) + S.synthesize_symbolic_expansion original_sv see; + (* Return *) + ctx (* Boxes *) | DerefBox, T.Adt (T.Assumed T.Box, [], [ boxed_ty ]) -> - let ctx, nv = + let ctx, see = compute_expanded_symbolic_box_value ended_regions boxed_ty ctx in (* Apply in the context *) - apply_symbolic_expansion_non_borrow config sp.V.svalue nv ctx + let ctx = + apply_symbolic_expansion_non_borrow config original_sv see ctx + in + (* Update the synthesized program *) + S.synthesize_symbolic_expansion original_sv see; + (* Return *) + ctx (* Borrows *) | Deref, T.Ref (region, ref_ty, rkind) -> - expand_symbolic_value_borrow config sp.V.svalue ended_regions region + expand_symbolic_value_borrow config original_sv ended_regions region ref_ty rkind ctx | _ -> failwith ("Unreachable: " ^ E.show_projection_elem pe ^ ", " ^ T.show_rty rty) in (* Sanity check: the symbolic value has disappeared *) - assert (not (symbolic_value_id_in_ctx sp.V.svalue.V.sv_id ctx)); + assert (not (symbolic_value_id_in_ctx original_sv.V.sv_id ctx)); (* Return *) ctx @@ -3032,8 +3059,9 @@ let eval_two_operands (config : C.config) (ctx : C.eval_ctx) (op1 : E.operand) | ctx, [ v1; v2 ] -> (ctx, v1, v2) | _ -> failwith "Unreachable" -let eval_unary_op (config : C.config) (ctx : C.eval_ctx) (unop : E.unop) - (op : E.operand) : (C.eval_ctx * V.typed_value) eval_result = +let eval_unary_op_concrete (config : C.config) (ctx : C.eval_ctx) + (unop : E.unop) (op : E.operand) : (C.eval_ctx * V.typed_value) eval_result + = (* Evaluate the operand *) let ctx, v = eval_operand config ctx op in (* Apply the unop *) @@ -3048,8 +3076,20 @@ let eval_unary_op (config : C.config) (ctx : C.eval_ctx) (unop : E.unop) | (E.Not | E.Neg), Symbolic _ -> raise Unimplemented (* TODO *) | _ -> failwith "Invalid value for unop" -let eval_binary_op (config : C.config) (ctx : C.eval_ctx) (binop : E.binop) - (op1 : E.operand) (op2 : E.operand) : +let eval_unary_op_symbolic (config : C.config) (ctx : C.eval_ctx) + (unop : E.unop) (op : E.operand) : (C.eval_ctx * V.typed_value) eval_result + = + S.synthesize_unary_op unop op; + raise Unimplemented + +let eval_unary_op (config : C.config) (ctx : C.eval_ctx) (unop : E.unop) + (op : E.operand) : (C.eval_ctx * V.typed_value) eval_result = + match config.mode with + | C.ConcreteMode -> eval_unary_op_concrete config ctx unop op + | C.SymbolicMode -> eval_unary_op_symbolic config ctx unop op + +let eval_binary_op_concrete (config : C.config) (ctx : C.eval_ctx) + (binop : E.binop) (op1 : E.operand) (op2 : E.operand) : (C.eval_ctx * V.typed_value) eval_result = (* Evaluate the operands *) let ctx, v1, v2 = eval_two_operands config ctx op1 op2 in @@ -3123,6 +3163,19 @@ let eval_binary_op (config : C.config) (ctx : C.eval_ctx) (binop : E.binop) match res with Error _ -> Error Panic | Ok v -> Ok (ctx, v)) | _ -> failwith "Invalid inputs for binop" +let eval_binary_op_symbolic (config : C.config) (ctx : C.eval_ctx) + (binop : E.binop) (op1 : E.operand) (op2 : E.operand) : + (C.eval_ctx * V.typed_value) eval_result = + S.synthesize_binary_op binop op1 op2; + raise Unimplemented + +let eval_binary_op (config : C.config) (ctx : C.eval_ctx) (binop : E.binop) + (op1 : E.operand) (op2 : E.operand) : + (C.eval_ctx * V.typed_value) eval_result = + match config.mode with + | C.ConcreteMode -> eval_binary_op_concrete config ctx binop op1 op2 + | C.SymbolicMode -> eval_binary_op_symbolic config ctx binop op1 op2 + (** Evaluate an rvalue in a given context: return the updated context and the computed value *) diff --git a/src/InterpreterUtils.ml b/src/InterpreterUtils.ml index 9e891348..4633664f 100644 --- a/src/InterpreterUtils.ml +++ b/src/InterpreterUtils.ml @@ -620,3 +620,10 @@ let update_aborrow (ek : exploration_kind) (l : V.BorrowId.id) (nv : V.avalue) (* Check that we updated at least one borrow *) assert !r; ctx + +(** TODO: move to InterpreterSymbolic or sth *) +type symbolic_expansion = + | SeConcrete of V.constant_value + | SeAdt of (T.VariantId.id option * V.symbolic_proj_comp list) + | SeMutRef of V.BorrowId.id * V.symbolic_proj_comp + | SeSharedRef of V.BorrowId.set_t * V.symbolic_proj_comp -- cgit v1.2.3 From ec5649b9cf9044c7415452b598492c3334451504 Mon Sep 17 00:00:00 2001 From: Son Ho Date: Wed, 5 Jan 2022 08:05:13 +0100 Subject: Make progress on inserting more calls for synthesis --- src/Interpreter.ml | 214 ++++++++++++++++++++++++++++------------------------- 1 file changed, 112 insertions(+), 102 deletions(-) (limited to 'src') diff --git a/src/Interpreter.ml b/src/Interpreter.ml index e27aaaa8..d7004371 100644 --- a/src/Interpreter.ml +++ b/src/Interpreter.ml @@ -3176,6 +3176,114 @@ let eval_binary_op (config : C.config) (ctx : C.eval_ctx) (binop : E.binop) | C.ConcreteMode -> eval_binary_op_concrete config ctx binop op1 op2 | C.SymbolicMode -> eval_binary_op_symbolic config ctx binop op1 op2 +let eval_rvalue_discriminant (config : C.config) (ctx : C.eval_ctx) + (p : E.place) : (C.eval_ctx * V.typed_value) eval_result = + S.synthesize_eval_rvalue_discriminant p; + (* Note that discriminant values have type `isize` *) + (* Access the value *) + let access = Read in + let ctx, v = prepare_rplace config access p ctx in + match v.V.value with + | Adt av -> ( + match av.variant_id with + | None -> + failwith "Invalid input for `discriminant`: structure instead of enum" + | Some variant_id -> ( + let id = Z.of_int (T.VariantId.to_int variant_id) in + match mk_scalar Isize id with + | Error _ -> + failwith "Disciminant id out of range" + (* Should really never happen *) + | Ok sv -> + Ok + (ctx, { V.value = V.Concrete (V.Scalar sv); ty = Integer Isize }) + )) + | Symbolic _ -> raise Unimplemented + | _ -> failwith "Invalid input for `discriminant`" + +let eval_rvalue_ref (config : C.config) (ctx : C.eval_ctx) (p : E.place) + (bkind : E.borrow_kind) : (C.eval_ctx * V.typed_value) eval_result = + S.synthesize_eval_rvalue_ref p bkind; + match bkind with + | E.Shared | E.TwoPhaseMut -> + (* Access the value *) + let access = if bkind = E.Shared then Read else Write in + let ctx, v = prepare_rplace config access p ctx in + (* Compute the rvalue - simply a shared borrow with a fresh id *) + let ctx, bid = C.fresh_borrow_id ctx in + (* Note that the reference is *mutable* if we do a two-phase borrow *) + let rv_ty = + T.Ref (T.Erased, v.ty, if bkind = E.Shared then Shared else Mut) + in + let bc = + if bkind = E.Shared then V.SharedBorrow bid + else V.InactivatedMutBorrow bid + in + let rv : V.typed_value = { V.value = V.Borrow bc; ty = rv_ty } in + (* Compute the value with which to replace the value at place p *) + let nv = + match v.V.value with + | V.Loan (V.SharedLoan (bids, sv)) -> + (* Shared loan: insert the new borrow id *) + let bids1 = V.BorrowId.Set.add bid bids in + { v with V.value = V.Loan (V.SharedLoan (bids1, sv)) } + | _ -> + (* Not a shared loan: add a wrapper *) + let v' = V.Loan (V.SharedLoan (V.BorrowId.Set.singleton bid, v)) in + { v with V.value = v' } + in + (* Update the value in the context *) + let ctx = write_place_unwrap config access p nv ctx in + (* Return *) + Ok (ctx, rv) + | E.Mut -> + (* Access the value *) + let access = Write in + let ctx, v = prepare_rplace config access p ctx in + (* Compute the rvalue - wrap the value in a mutable borrow with a fresh id *) + let ctx, bid = C.fresh_borrow_id ctx in + let rv_ty = T.Ref (T.Erased, v.ty, Mut) in + let rv : V.typed_value = + { V.value = V.Borrow (V.MutBorrow (bid, v)); ty = rv_ty } + in + (* Compute the value with which to replace the value at place p *) + let nv = { v with V.value = V.Loan (V.MutLoan bid) } in + (* Update the value in the context *) + let ctx = write_place_unwrap config access p nv ctx in + (* Return *) + Ok (ctx, rv) + +let eval_rvalue_aggregate (config : C.config) (ctx : C.eval_ctx) + (aggregate_kind : E.aggregate_kind) (ops : E.operand list) : + (C.eval_ctx * V.typed_value) eval_result = + S.synthesize_eval_rvalue_aggregate aggregate_kind ops; + (* Evaluate the operands *) + let ctx, values = eval_operands config ctx ops in + (* Match on the aggregate kind *) + match aggregate_kind with + | E.AggregatedTuple -> + let tys = List.map (fun (v : V.typed_value) -> v.V.ty) values in + let v = V.Adt { variant_id = None; field_values = values } in + let ty = T.Adt (T.Tuple, [], tys) in + Ok (ctx, { V.value = v; ty }) + | E.AggregatedAdt (def_id, opt_variant_id, regions, types) -> + (* Sanity checks *) + let type_def = C.ctx_lookup_type_def ctx def_id in + assert (List.length type_def.region_params = List.length regions); + let expected_field_types = + Subst.ctx_adt_get_instantiated_field_etypes ctx def_id opt_variant_id + types + in + assert ( + expected_field_types + = List.map (fun (v : V.typed_value) -> v.V.ty) values); + (* Construct the value *) + let av : V.adt_value = + { V.variant_id = opt_variant_id; V.field_values = values } + in + let aty = T.Adt (T.AdtId def_id, regions, types) in + Ok (ctx, { V.value = Adt av; ty = aty }) + (** Evaluate an rvalue in a given context: return the updated context and the computed value *) @@ -3183,110 +3291,12 @@ let eval_rvalue (config : C.config) (ctx : C.eval_ctx) (rvalue : E.rvalue) : (C.eval_ctx * V.typed_value) eval_result = match rvalue with | E.Use op -> Ok (eval_operand config ctx op) - | E.Ref (p, bkind) -> ( - match bkind with - | E.Shared | E.TwoPhaseMut -> - (* Access the value *) - let access = if bkind = E.Shared then Read else Write in - let ctx, v = prepare_rplace config access p ctx in - (* Compute the rvalue - simply a shared borrow with a fresh id *) - let ctx, bid = C.fresh_borrow_id ctx in - (* Note that the reference is *mutable* if we do a two-phase borrow *) - let rv_ty = - T.Ref (T.Erased, v.ty, if bkind = E.Shared then Shared else Mut) - in - let bc = - if bkind = E.Shared then V.SharedBorrow bid - else V.InactivatedMutBorrow bid - in - let rv : V.typed_value = { V.value = V.Borrow bc; ty = rv_ty } in - (* Compute the value with which to replace the value at place p *) - let nv = - match v.V.value with - | V.Loan (V.SharedLoan (bids, sv)) -> - (* Shared loan: insert the new borrow id *) - let bids1 = V.BorrowId.Set.add bid bids in - { v with V.value = V.Loan (V.SharedLoan (bids1, sv)) } - | _ -> - (* Not a shared loan: add a wrapper *) - let v' = - V.Loan (V.SharedLoan (V.BorrowId.Set.singleton bid, v)) - in - { v with V.value = v' } - in - (* Update the value in the context *) - let ctx = write_place_unwrap config access p nv ctx in - (* Return *) - Ok (ctx, rv) - | E.Mut -> - (* Access the value *) - let access = Write in - let ctx, v = prepare_rplace config access p ctx in - (* Compute the rvalue - wrap the value in a mutable borrow with a fresh id *) - let ctx, bid = C.fresh_borrow_id ctx in - let rv_ty = T.Ref (T.Erased, v.ty, Mut) in - let rv : V.typed_value = - { V.value = V.Borrow (V.MutBorrow (bid, v)); ty = rv_ty } - in - (* Compute the value with which to replace the value at place p *) - let nv = { v with V.value = V.Loan (V.MutLoan bid) } in - (* Update the value in the context *) - let ctx = write_place_unwrap config access p nv ctx in - (* Return *) - Ok (ctx, rv)) + | E.Ref (p, bkind) -> eval_rvalue_ref config ctx p bkind | E.UnaryOp (unop, op) -> eval_unary_op config ctx unop op | E.BinaryOp (binop, op1, op2) -> eval_binary_op config ctx binop op1 op2 - | E.Discriminant p -> ( - (* Note that discriminant values have type `isize` *) - (* Access the value *) - let access = Read in - let ctx, v = prepare_rplace config access p ctx in - match v.V.value with - | Adt av -> ( - match av.variant_id with - | None -> - failwith - "Invalid input for `discriminant`: structure instead of enum" - | Some variant_id -> ( - let id = Z.of_int (T.VariantId.to_int variant_id) in - match mk_scalar Isize id with - | Error _ -> - failwith "Disciminant id out of range" - (* Should really never happen *) - | Ok sv -> - Ok - ( ctx, - { V.value = V.Concrete (V.Scalar sv); ty = Integer Isize } - ))) - | Symbolic _ -> raise Unimplemented - | _ -> failwith "Invalid input for `discriminant`") - | E.Aggregate (aggregate_kind, ops) -> ( - (* Evaluate the operands *) - let ctx, values = eval_operands config ctx ops in - (* Match on the aggregate kind *) - match aggregate_kind with - | E.AggregatedTuple -> - let tys = List.map (fun (v : V.typed_value) -> v.V.ty) values in - let v = V.Adt { variant_id = None; field_values = values } in - let ty = T.Adt (T.Tuple, [], tys) in - Ok (ctx, { V.value = v; ty }) - | E.AggregatedAdt (def_id, opt_variant_id, regions, types) -> - (* Sanity checks *) - let type_def = C.ctx_lookup_type_def ctx def_id in - assert (List.length type_def.region_params = List.length regions); - let expected_field_types = - Subst.ctx_adt_get_instantiated_field_etypes ctx def_id - opt_variant_id types - in - assert ( - expected_field_types - = List.map (fun (v : V.typed_value) -> v.V.ty) values); - (* Construct the value *) - let av : V.adt_value = - { V.variant_id = opt_variant_id; V.field_values = values } - in - let aty = T.Adt (T.AdtId def_id, regions, types) in - Ok (ctx, { V.value = Adt av; ty = aty })) + | E.Discriminant p -> eval_rvalue_discriminant config ctx p + | E.Aggregate (aggregate_kind, ops) -> + eval_rvalue_aggregate config ctx aggregate_kind ops (** Result of evaluating a statement *) type statement_eval_res = Unit | Break of int | Continue of int | Return -- cgit v1.2.3 From 27707043055bd2ea198f548fa84b672fe5279880 Mon Sep 17 00:00:00 2001 From: Son Ho Date: Wed, 5 Jan 2022 08:12:28 +0100 Subject: Add more calls to synthesis functions --- src/Interpreter.ml | 7 ++++++- src/Synthesis.ml | 59 ++++++++++++++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 65 insertions(+), 1 deletion(-) create mode 100644 src/Synthesis.ml (limited to 'src') diff --git a/src/Interpreter.ml b/src/Interpreter.ml index d7004371..1107ee20 100644 --- a/src/Interpreter.ml +++ b/src/Interpreter.ml @@ -3359,6 +3359,7 @@ let rec end_loan_exactly_at_place (config : C.config) (access : access_kind) let set_discriminant (config : C.config) (ctx : C.eval_ctx) (p : E.place) (variant_id : T.VariantId.id) : (C.eval_ctx * statement_eval_res) eval_result = + S.synthesize_set_discriminant p variant_id; (* Access the value *) let access = Write in let ctx = update_ctx_along_read_place config access p ctx in @@ -3633,6 +3634,9 @@ let eval_non_local_function_call (config : C.config) (ctx : C.eval_ctx) ^ "\n- type_params: " ^ type_params ^ "\n- args: " ^ args ^ "\n- dest: " ^ dest)); + (* Synthesis *) + S.synthesize_non_local_function_call fid region_params type_params args dest; + (* There are two cases (and this is extremely annoying): - the function is not box_free - the function is box_free @@ -3816,9 +3820,10 @@ and eval_function_call (config : C.config) (ctx : C.eval_ctx) (call : A.call) : (** Evaluate a local (i.e, not assumed) function call (auxiliary helper for [eval_statement]) *) and eval_local_function_call (config : C.config) (ctx : C.eval_ctx) - (fid : A.FunDefId.id) (_region_params : T.erased_region list) + (fid : A.FunDefId.id) (region_params : T.erased_region list) (type_params : T.ety list) (args : E.operand list) (dest : E.place) : C.eval_ctx eval_result = + S.synthesize_local_function_call fid region_params type_params args dest; (* Retrieve the (correctly instantiated) body *) let def = C.ctx_lookup_fun_def ctx fid in match config.mode with diff --git a/src/Synthesis.ml b/src/Synthesis.ml new file mode 100644 index 00000000..85029a58 --- /dev/null +++ b/src/Synthesis.ml @@ -0,0 +1,59 @@ +module T = Types +module V = Values +open Scalars +module E = Expressions +open Errors +module C = Contexts +module Subst = Substitute +module A = CfimAst +module L = Logging +open TypesUtils +open ValuesUtils +module Inv = Invariants +open InterpreterUtils + +(* TODO: the below functions have very "rough" signatures and do nothing: I + * defined them so that the places where we should update the synthesized + * program are clearly indicated in Interpreter.ml. + * + * Small rk.: most functions should take an additional parameter for the + * fresh symbolic value which stores the result of the computation. + * For instance: + * `synthesize_binary_op Add op1 op2 s` + * should generate: + * `s := op1 + op2` + * *) + +(** TODO: rename to synthesize_symbolic_expansion_{non_enum,one_variant}? *) +let synthesize_symbolic_expansion (sv : V.symbolic_value) + (see : symbolic_expansion) : unit = + () + +let synthesize_unary_op (unop : E.unop) (op : E.operand) : unit = () + +let synthesize_binary_op (binop : E.binop) (op1 : E.operand) (op2 : E.operand) : + unit = + () + +(** Actually not sure if we need this, or a synthesize_symbolic_expansion_enum *) +let synthesize_eval_rvalue_discriminant (p : E.place) : unit = () + +let synthesize_eval_rvalue_ref (p : E.place) (bkind : E.borrow_kind) : unit = () + +let synthesize_eval_rvalue_aggregate (aggregate_kind : E.aggregate_kind) + (ops : E.operand list) : unit = + () + +let synthesize_set_discriminant (p : E.place) (variant_id : T.VariantId.id) : + unit = + () + +let synthesize_non_local_function_call (fid : A.assumed_fun_id) + (region_params : T.erased_region list) (type_params : T.ety list) + (args : E.operand list) (dest : E.place) : unit = + () + +let synthesize_local_function_call (fid : A.FunDefId.id) + (region_params : T.erased_region list) (type_params : T.ety list) + (args : E.operand list) (dest : E.place) : unit = + () -- cgit v1.2.3 From 31ba5d8703e1c5030744e4e2818aec2b6928e30c Mon Sep 17 00:00:00 2001 From: Son Ho Date: Wed, 5 Jan 2022 08:13:14 +0100 Subject: Update a comment --- src/Synthesis.ml | 2 ++ 1 file changed, 2 insertions(+) (limited to 'src') diff --git a/src/Synthesis.ml b/src/Synthesis.ml index 85029a58..1519d0f0 100644 --- a/src/Synthesis.ml +++ b/src/Synthesis.ml @@ -15,6 +15,8 @@ open InterpreterUtils (* TODO: the below functions have very "rough" signatures and do nothing: I * defined them so that the places where we should update the synthesized * program are clearly indicated in Interpreter.ml. + * Also, some of those functions will probably be split, and their call site + * will probably evolve. * * Small rk.: most functions should take an additional parameter for the * fresh symbolic value which stores the result of the computation. -- cgit v1.2.3 From 05db1377f1b987050e58643b9bf001f62a77e303 Mon Sep 17 00:00:00 2001 From: Son Ho Date: Wed, 5 Jan 2022 08:43:24 +0100 Subject: Introduce the type_context definition --- src/CfimAst.ml | 7 +++++++ src/Contexts.ml | 6 ++++-- src/Interpreter.ml | 21 +++++++++++---------- src/Invariants.ml | 4 ++-- src/Print.ml | 10 ++++++---- src/main.ml | 40 +++++++++++++++++++++++----------------- 6 files changed, 53 insertions(+), 35 deletions(-) (limited to 'src') diff --git a/src/CfimAst.ml b/src/CfimAst.ml index 192638cf..6c9b596e 100644 --- a/src/CfimAst.ml +++ b/src/CfimAst.ml @@ -86,3 +86,10 @@ type fun_def = { body : statement; } [@@deriving show] +(** TODO: the type and function definitions contain information like `divergent` + * or `copyable`. I wonder if this information should be stored directly inside + * the definitions or inside separate maps/sets. + * Of course, if everything is stored in separate maps/sets, nothing + * prevents us from computing this info in Charon (and thus exporting directly + * it with the type/function defs), in which case we just have to implement special + * treatment when deserializing, to move the info to a separate map. *) diff --git a/src/Contexts.ml b/src/Contexts.ml index 5e8ae3d0..521ea0ed 100644 --- a/src/Contexts.ml +++ b/src/Contexts.ml @@ -60,8 +60,10 @@ type interpreter_mode = ConcreteMode | SymbolicMode [@@deriving show] type config = { mode : interpreter_mode; check_invariants : bool } [@@deriving show] +type type_context = { type_defs : type_def list } [@@deriving show] + type eval_ctx = { - type_context : type_def list; + type_context : type_context; fun_context : fun_def list; type_vars : type_var list; env : env; @@ -94,7 +96,7 @@ let ctx_lookup_binder (ctx : eval_ctx) (vid : VarId.id) : binder = lookup ctx.env let ctx_lookup_type_def (ctx : eval_ctx) (tid : TypeDefId.id) : type_def = - TypeDefId.nth ctx.type_context tid + TypeDefId.nth ctx.type_context.type_defs tid let ctx_lookup_fun_def (ctx : eval_ctx) (fid : FunDefId.id) : fun_def = FunDefId.nth ctx.fun_context fid diff --git a/src/Interpreter.ml b/src/Interpreter.ml index 1107ee20..a335a0d5 100644 --- a/src/Interpreter.ml +++ b/src/Interpreter.ml @@ -2361,8 +2361,8 @@ let expand_bottom_value_from_projection (config : C.config) | ( Field (ProjAdt (def_id, opt_variant_id), _), T.Adt (T.AdtId def_id', regions, types) ) -> assert (def_id = def_id'); - compute_expanded_bottom_adt_value ctx.type_context def_id opt_variant_id - regions types + compute_expanded_bottom_adt_value ctx.type_context.type_defs def_id + opt_variant_id regions types (* Tuples *) | Field (ProjTuple arity, _), T.Adt (T.Tuple, [], tys) -> assert (arity = List.length tys); @@ -2391,7 +2391,7 @@ let compute_expanded_symbolic_adt_value (expand_enumerations : bool) (ctx : C.eval_ctx) : (C.eval_ctx * symbolic_expansion) list = (* Lookup the definition and check if it is an enumeration with several * variants *) - let def = T.TypeDefId.nth ctx.type_context def_id in + let def = C.ctx_lookup_type_def ctx def_id in assert (List.length regions = List.length def.T.region_params); (* Retrieve, for every variant, the list of its instantiated field types *) let variants_fields_types = @@ -2976,7 +2976,7 @@ let constant_value_to_typed_value (ctx : C.eval_ctx) (ty : T.ety) assert (def_id = def_id'); (* Check that the adt definition only has one variant with no fields, compute the variant id at the same time. *) - let def = T.TypeDefId.nth ctx.type_context def_id in + let def = C.ctx_lookup_type_def ctx def_id in assert (List.length def.region_params = 0); assert (List.length def.type_params = 0); let variant_id = @@ -3382,14 +3382,14 @@ let set_discriminant (config : C.config) (ctx : C.eval_ctx) (p : E.place) else (* Replace the value *) let bottom_v = - compute_expanded_bottom_adt_value ctx.type_context def_id - (Some variant_id) regions types + compute_expanded_bottom_adt_value ctx.type_context.type_defs + def_id (Some variant_id) regions types in let ctx = write_place_unwrap config access p bottom_v ctx in Ok (ctx, Unit)) | T.Adt (T.AdtId def_id, regions, types), V.Bottom -> let bottom_v = - compute_expanded_bottom_adt_value ctx.type_context def_id + compute_expanded_bottom_adt_value ctx.type_context.type_defs def_id (Some variant_id) regions types in let ctx = write_place_unwrap config access p bottom_v ctx in @@ -3894,7 +3894,7 @@ module Test = struct (** Test a unit function (taking no arguments) by evaluating it in an empty environment *) - let test_unit_function (type_defs : T.type_def list) + let test_unit_function (type_context : C.type_context) (fun_defs : A.fun_def list) (fid : A.FunDefId.id) : unit eval_result = (* Retrieve the function declaration *) let fdef = A.FunDefId.nth fun_defs fid in @@ -3911,7 +3911,7 @@ module Test = struct (* Create the evaluation context *) let ctx = { - C.type_context = type_defs; + C.type_context; C.fun_context = fun_defs; C.type_vars = []; C.env = []; @@ -3942,7 +3942,8 @@ module Test = struct (fun_defs : A.fun_def list) : unit = let test_fun (def : A.fun_def) : unit = if fun_def_is_unit def then - match test_unit_function type_defs fun_defs def.A.def_id with + let type_ctx = { C.type_defs } in + match test_unit_function type_ctx fun_defs def.A.def_id with | Error _ -> failwith "Unit test failed" | Ok _ -> () else () diff --git a/src/Invariants.ml b/src/Invariants.ml index fec6b2ed..364c14d0 100644 --- a/src/Invariants.ml +++ b/src/Invariants.ml @@ -352,7 +352,7 @@ let check_typing_invariant (ctx : C.eval_ctx) : unit = | V.Adt av, T.Adt (T.AdtId def_id, regions, tys) -> (* Retrieve the definition to check the variant id, the number of * parameters, etc. *) - let def = T.TypeDefId.nth ctx.type_context def_id in + let def = C.ctx_lookup_type_def ctx def_id in (* Check the number of parameters *) assert (List.length regions = List.length def.region_params); assert (List.length tys = List.length def.type_params); @@ -435,7 +435,7 @@ let check_typing_invariant (ctx : C.eval_ctx) : unit = | V.AAdt av, T.Adt (T.AdtId def_id, regions, tys) -> (* Retrieve the definition to check the variant id, the number of * parameters, etc. *) - let def = T.TypeDefId.nth ctx.type_context def_id in + let def = C.ctx_lookup_type_def ctx def_id in (* Check the number of parameters *) assert (List.length regions = List.length def.region_params); assert (List.length tys = List.length def.type_params); diff --git a/src/Print.ml b/src/Print.ml index 2fd7e336..90f3946b 100644 --- a/src/Print.ml +++ b/src/Print.ml @@ -492,17 +492,19 @@ module Contexts = struct v.name in let type_def_id_to_string def_id = - let def = T.TypeDefId.nth ctx.type_context def_id in + let def = T.TypeDefId.nth ctx.type_context.type_defs def_id in PT.name_to_string def.name in let adt_variant_to_string = - type_ctx_to_adt_variant_to_string_fun ctx.type_context + type_ctx_to_adt_variant_to_string_fun ctx.type_context.type_defs in let var_id_to_string vid = let bv = C.ctx_lookup_binder ctx vid in binder_to_string bv in - let adt_field_names = type_ctx_to_adt_field_names_fun ctx.C.type_context in + let adt_field_names = + type_ctx_to_adt_field_names_fun ctx.type_context.type_defs + in { rvar_to_string; r_to_string; @@ -604,7 +606,7 @@ module CfimAst = struct let eval_ctx_to_ast_formatter (ctx : C.eval_ctx) : ast_formatter = let ctx_fmt = PC.eval_ctx_to_ctx_formatter ctx in let adt_field_to_string = - type_ctx_to_adt_field_to_string_fun ctx.type_context + type_ctx_to_adt_field_to_string_fun ctx.type_context.type_defs in let fun_def_id_to_string def_id = let def = A.FunDefId.nth ctx.fun_context def_id in diff --git a/src/main.ml b/src/main.ml index 4616aadf..f2e6eb06 100644 --- a/src/main.ml +++ b/src/main.ml @@ -1,9 +1,11 @@ open CfimOfJson open Logging open Print +open Contexts module T = Types module A = CfimAst module I = Interpreter +module C = Contexts type test = Test [@@deriving show] @@ -13,31 +15,35 @@ let _ = show_test Test * reason, the -g option doesn't work *) let () = Printexc.record_backtrace true -let usage = Printf.sprintf {|Aenaes: verification of Rust programs by translation +let usage = + Printf.sprintf + {|Aenaes: verification of Rust programs by translation Usage: %s [OPTIONS] FILE -|} Sys.argv.(0);; +|} + Sys.argv.(0) let () = - let spec = [ - ] in + let spec = [] in let spec = Arg.align spec in let filename = ref "" in - let fail () = print_string usage; exit 1 in - Arg.parse spec (fun f -> - if not (Filename.check_suffix f ".cfim") then begin - print_string "Unrecognized file extension"; - fail () - end else if not (Sys.file_exists f) then begin - print_string "File not found"; - fail () - end else - filename := f - ) usage; - if !filename = "" then begin + let fail () = print_string usage; exit 1 - end; + in + Arg.parse spec + (fun f -> + if not (Filename.check_suffix f ".cfim") then ( + print_string "Unrecognized file extension"; + fail ()) + else if not (Sys.file_exists f) then ( + print_string "File not found"; + fail ()) + else filename := f) + usage; + if !filename = "" then ( + print_string usage; + exit 1); let json = Yojson.Basic.from_file !filename in match cfim_module_of_json json with | Error s -> log#error "error: %s\n" s -- cgit v1.2.3 From d7ac73c207461559f55623e8ff61d2bb7e5cf982 Mon Sep 17 00:00:00 2001 From: Son Ho Date: Wed, 5 Jan 2022 08:44:10 +0100 Subject: Cleanup a bit --- src/main.ml | 6 ------ 1 file changed, 6 deletions(-) (limited to 'src') diff --git a/src/main.ml b/src/main.ml index f2e6eb06..2d2518c7 100644 --- a/src/main.ml +++ b/src/main.ml @@ -1,15 +1,9 @@ open CfimOfJson open Logging open Print -open Contexts module T = Types module A = CfimAst module I = Interpreter -module C = Contexts - -type test = Test [@@deriving show] - -let _ = show_test Test (* This is necessary to have a backtrace when raising exceptions - for some * reason, the -g option doesn't work *) -- cgit v1.2.3 From 882f7840d9a110cfc138fe376447783d63118223 Mon Sep 17 00:00:00 2001 From: Son Ho Date: Wed, 5 Jan 2022 09:03:21 +0100 Subject: Implement the symbolic case of copy_value --- src/CfimAst.ml | 6 +++--- src/Interpreter.ml | 36 +++++++++++++++++++++++++++++++++--- 2 files changed, 36 insertions(+), 6 deletions(-) (limited to 'src') diff --git a/src/CfimAst.ml b/src/CfimAst.ml index 6c9b596e..250cd223 100644 --- a/src/CfimAst.ml +++ b/src/CfimAst.ml @@ -86,9 +86,9 @@ type fun_def = { body : statement; } [@@deriving show] -(** TODO: the type and function definitions contain information like `divergent` - * or `copyable`. I wonder if this information should be stored directly inside - * the definitions or inside separate maps/sets. +(** TODO: function definitions (and maybe type definitions in the future) + * contain information like `divergent`. I wonder if this information should + * be stored directly inside the definitions or inside separate maps/sets. * Of course, if everything is stored in separate maps/sets, nothing * prevents us from computing this info in Charon (and thus exporting directly * it with the type/function defs), in which case we just have to implement special diff --git a/src/Interpreter.ml b/src/Interpreter.ml index a335a0d5..3c24f38a 100644 --- a/src/Interpreter.ml +++ b/src/Interpreter.ml @@ -2917,10 +2917,30 @@ let rec drop_borrows_loans_at_lplace (config : C.config) (p : E.place) ctx with UpdateCtx ctx -> drop_borrows_loans_at_lplace config p ctx) +(** Return true if a type is "primitively copyable". + * + * "primitively copyable" means that copying instances of this type doesn't + * require calling dedicated functions defined through the Copy trait. It + * is the case for types like integers, shared borrows, etc. + *) +let rec type_is_primitively_copyable (ty : T.ety) : bool = + match ty with + | T.Adt (_, _, _) | T.TypeVar _ | T.Never | T.Str | T.Array _ | T.Slice _ -> + false + | T.Bool | T.Char | T.Integer _ -> true + | T.Ref (_, _, T.Mut) -> false + | T.Ref (_, _, T.Shared) -> true + (** Copy a value, and return the resulting value. Note that copying values might update the context. For instance, when copying shared borrows, we need to insert new shared borrows in the context. + + Also, this function is actually more general than it should be: it allows + to copy ADTs, while ADT copy should be done through the Copy trait (i.e., + by calling a dedicated function). + TODO: maybe we should disallow the copy of ADTs, or control it through + a boolean... *) let rec copy_value (config : C.config) (ctx : C.eval_ctx) (v : V.typed_value) : C.eval_ctx * V.typed_value = @@ -2960,9 +2980,19 @@ let rec copy_value (config : C.config) (ctx : C.eval_ctx) (v : V.typed_value) : | V.SharedLoan (_, sv) -> (* We don't copy the shared loan: only the shared value inside *) copy_value config ctx sv) - | V.Symbolic _sp -> - (* TODO: check that the value is copyable *) - raise Unimplemented + | V.Symbolic sp -> + (* We can copy only if the type is "primitively" copyable. + * Note that in the general case, copy is a trait: copying values + * thus requires calling the proper function. Here, we copy values + * for very simple types such as integers, shared borrows, etc. *) + assert ( + type_is_primitively_copyable (Subst.erase_regions sp.V.svalue.V.sv_ty)); + (* If the type is copyable, we simply return the current value. Side + * remark: what is important to look at when copying symbolic values + * is symbolic expansion. The important subcase is the expansion of shared + * borrows: when doing so, every occurrence of the same symbolic value + * must use a fresh borrow id. *) + (ctx, v) (** Convert a constant operand value to a typed value *) let constant_value_to_typed_value (ctx : C.eval_ctx) (ty : T.ety) -- cgit v1.2.3 From cc3e866f4a354c6e305bd9737dd46b0648e172af Mon Sep 17 00:00:00 2001 From: Son Ho Date: Wed, 5 Jan 2022 09:05:34 +0100 Subject: Make minor modifications --- src/Interpreter.ml | 23 +++++++++++++---------- 1 file changed, 13 insertions(+), 10 deletions(-) (limited to 'src') diff --git a/src/Interpreter.ml b/src/Interpreter.ml index 3c24f38a..a123f046 100644 --- a/src/Interpreter.ml +++ b/src/Interpreter.ml @@ -2936,14 +2936,13 @@ let rec type_is_primitively_copyable (ty : T.ety) : bool = Note that copying values might update the context. For instance, when copying shared borrows, we need to insert new shared borrows in the context. - Also, this function is actually more general than it should be: it allows - to copy ADTs, while ADT copy should be done through the Copy trait (i.e., - by calling a dedicated function). - TODO: maybe we should disallow the copy of ADTs, or control it through - a boolean... + Also, this function is actually more general than it should be: it can be used + to copy concrete ADT values, while ADT copy should be done through the Copy + trait (i.e., by calling a dedicated function). This is why we added a parameter + to control this copy. *) -let rec copy_value (config : C.config) (ctx : C.eval_ctx) (v : V.typed_value) : - C.eval_ctx * V.typed_value = +let rec copy_value (allow_adt_copy : bool) (config : C.config) + (ctx : C.eval_ctx) (v : V.typed_value) : C.eval_ctx * V.typed_value = (* Remark: at some point we rewrote this function to use iterators, but then * we reverted the changes: the result was less clear actually. In particular, * the fact that we have exhaustive matches below makes very obvious the cases @@ -2951,13 +2950,16 @@ let rec copy_value (config : C.config) (ctx : C.eval_ctx) (v : V.typed_value) : match v.V.value with | V.Concrete _ -> (ctx, v) | V.Adt av -> + assert allow_adt_copy; (* Sanity check *) (match v.V.ty with | T.Adt (T.Assumed _, _, _) -> failwith "Can't copy an assumed value" | T.Adt ((T.AdtId _ | T.Tuple), _, _) -> () (* Ok *) | _ -> failwith "Unreachable"); let ctx, fields = - List.fold_left_map (copy_value config) ctx av.field_values + List.fold_left_map + (copy_value allow_adt_copy config) + ctx av.field_values in (ctx, { v with V.value = V.Adt { av with field_values = fields } }) | V.Bottom -> failwith "Can't copy ⊥" @@ -2979,7 +2981,7 @@ let rec copy_value (config : C.config) (ctx : C.eval_ctx) (v : V.typed_value) : | V.MutLoan _ -> failwith "Can't copy a mutable loan" | V.SharedLoan (_, sv) -> (* We don't copy the shared loan: only the shared value inside *) - copy_value config ctx sv) + copy_value allow_adt_copy config ctx sv) | V.Symbolic sp -> (* We can copy only if the type is "primitively" copyable. * Note that in the general case, copy is a trait: copying values @@ -3065,7 +3067,8 @@ let eval_operand (config : C.config) (ctx : C.eval_ctx) (op : E.operand) : (* Copy the value *) L.log#ldebug (lazy ("Value to copy:\n" ^ typed_value_to_string ctx v)); assert (not (bottom_in_value v)); - copy_value config ctx v + let allow_adt_copy = false in + copy_value allow_adt_copy config ctx v | Expressions.Move p -> ( (* Access the value *) let access = Move in -- cgit v1.2.3 From f204e2a5543257e77a4bc6ed666efa2f3c4ffabf Mon Sep 17 00:00:00 2001 From: Son Ho Date: Wed, 5 Jan 2022 10:13:13 +0100 Subject: Add comments about symbolic values --- src/Values.ml | 7 +++++-- 1 file changed, 5 insertions(+), 2 deletions(-) (limited to 'src') diff --git a/src/Values.ml b/src/Values.ml index 8ecf8849..a0bd96c5 100644 --- a/src/Values.ml +++ b/src/Values.ml @@ -54,10 +54,13 @@ type symbolic_value = { sv_id : SymbolicValueId.id; sv_ty : rty } - a projector on loans may see a symbolic value of id `sid` as having type `T` - a projector on borrows may see it as having type `&mut T` We need to make this clear and more consistant. - So [symbolic_value] is actually a projector. TODO: rename + So [symbolic_value] is actually a projector. TODO: rename to [symbolic_proj]. + The kind of projector will then depend on the context. *) -(** TODO: make it clear that complementary projectors are projectors on borrows *) +(** TODO: make it clear that complementary projectors are projectors on borrows. + ** TODO: actually this is useless: the set of ended regions should be global! + ** (and thus stored in the context) *) type symbolic_proj_comp = { svalue : symbolic_value; (** The symbolic value itself *) rset_ended : RegionId.set_t; -- cgit v1.2.3 From d658ff64adc746523568577668ce80034071d963 Mon Sep 17 00:00:00 2001 From: Son Ho Date: Wed, 5 Jan 2022 10:17:29 +0100 Subject: Update some comments --- src/Values.ml | 4 ++++ 1 file changed, 4 insertions(+) (limited to 'src') diff --git a/src/Values.ml b/src/Values.ml index a0bd96c5..0239da5e 100644 --- a/src/Values.ml +++ b/src/Values.ml @@ -56,6 +56,10 @@ type symbolic_value = { sv_id : SymbolicValueId.id; sv_ty : rty } We need to make this clear and more consistant. So [symbolic_value] is actually a projector. TODO: rename to [symbolic_proj]. The kind of projector will then depend on the context. + Actually, maybe we shouldn't use this type. Or for abstractions we should + use different types. Something like: + - [proj_borrows] for values + - [aproj_loans], [aproj_borrows] for avalues *) (** TODO: make it clear that complementary projectors are projectors on borrows. -- cgit v1.2.3 From f746abf4c631a860d8dafc83c47d569574bdc245 Mon Sep 17 00:00:00 2001 From: Son Ho Date: Wed, 5 Jan 2022 10:24:47 +0100 Subject: Fix a mistake in convert_avalue_to_value --- src/Interpreter.ml | 62 ++++++++++++++++++++++++------------------------------ 1 file changed, 27 insertions(+), 35 deletions(-) (limited to 'src') diff --git a/src/Interpreter.ml b/src/Interpreter.ml index a123f046..192dfe25 100644 --- a/src/Interpreter.ml +++ b/src/Interpreter.ml @@ -1267,38 +1267,34 @@ let give_back (config : C.config) (l : V.BorrowId.id) (bc : g_borrow_content) (** Convert an [avalue] to a [value]. This function is used when ending abstractions: whenever we end a borrow - in an abstraction, we converted the borrowed [avalue] to a [value], then give - back this [value] to the context. - - There are two possibilities: - - either the borrowed [avalue] contains ended regions, in which case we return ⊥ - - or it doesn't contain ⊥, in which case we simply return a newly introduced - symbolic value. - We return a new context because we may have to introduce a symbolic value. - - The `ended_regions` parameter is for the regions contained in the current - abstraction. + in an abstraction, we converted the borrowed [avalue] to a fresh symbolic + [value], then give back this [value] to the context. + + Note that some regions may have ended in the symbolic value we generate. + For instance, consider the following function signature: + ``` + fn f<'a>(x : &'a mut &'a mut u32); + ``` + When ending the abstraction, the value given back for the outer borrow + should be ⊥. In practice, we will give back a symbolic value which can't + be expanded (because expanding this symbolic value would require expanding + a reference whose region has already ended). *) -let convert_avalue_to_value (ended_regions : T.RegionId.set_t) - (av : V.typed_avalue) (ctx : C.eval_ctx) : C.eval_ctx * V.typed_value = +let convert_avalue_to_value (av : V.typed_avalue) (ctx : C.eval_ctx) : + C.eval_ctx * V.typed_value = (* Convert the type *) let ty = Subst.erase_regions av.V.ty in - (* Check if the avalue contains ended regions *) - if rty_regions_intersect av.V.ty ended_regions then - (* Contains ended regions: return ⊥ *) - (ctx, { V.value = V.Bottom; V.ty }) - else - (* Doesn't contain ended regions: return a symbolic value *) - let ctx, sv_id = C.fresh_symbolic_value_id ctx in - let svalue : V.symbolic_value = { V.sv_id; sv_ty = av.V.ty } in - let value : V.symbolic_proj_comp = - (* Note that the set of ended regions is empty: we shouldn't have to take - * into account any ended regions at this point, otherwise we would be in - * the first case where we should return ⊥ *) - { V.svalue; V.rset_ended = T.RegionId.Set.empty } - in - let value = V.Symbolic value in - (ctx, { V.value; V.ty }) + (* Generate the fresh a symbolic value *) + let ctx, sv_id = C.fresh_symbolic_value_id ctx in + let svalue : V.symbolic_value = { V.sv_id; sv_ty = av.V.ty } in + let value : V.symbolic_proj_comp = + (* Note that the set of ended regions is empty: we shouldn't have to take + * into account any ended regions at this point, otherwise we would be in + * the first case where we should return ⊥ *) + { V.svalue; V.rset_ended = T.RegionId.Set.empty } + in + let value = V.Symbolic value in + (ctx, { V.value; V.ty }) (** End a borrow identified by its borrow id in a context @@ -1564,12 +1560,8 @@ and end_abstraction_borrows (config : C.config) (abs_id : V.AbstractionId.id) let ctx = match bc with | V.AMutBorrow (bid, av) -> - (* First, convert the avalue to a value (by introducing the proper - * symbolic values). Note that we should probably use the regions owned - * by the abstraction for the ended_regions parameter, but for safety - * I'm using the accumulated regions (which include the ancestors' - * regions). Think a bit about that... *) - let ctx, v = convert_avalue_to_value abs.acc_regions av ctx in + (* First, convert the avalue to a (fresh symbolic) value *) + let ctx, v = convert_avalue_to_value av ctx in give_back_value config bid v ctx | V.ASharedBorrow bid -> give_back_shared config bid ctx | V.AProjSharedBorrow _ -> -- cgit v1.2.3 From e36de39e62d2120f9e337520ccc3d897b259094f Mon Sep 17 00:00:00 2001 From: Son Ho Date: Wed, 5 Jan 2022 10:36:33 +0100 Subject: Implement eval_unary_op_symbolic --- src/Interpreter.ml | 18 +++++++++++++++--- src/InterpreterUtils.ml | 5 +++++ src/Synthesis.ml | 4 +++- 3 files changed, 23 insertions(+), 4 deletions(-) (limited to 'src') diff --git a/src/Interpreter.ml b/src/Interpreter.ml index 192dfe25..44bd1b9e 100644 --- a/src/Interpreter.ml +++ b/src/Interpreter.ml @@ -3098,14 +3098,26 @@ let eval_unary_op_concrete (config : C.config) (ctx : C.eval_ctx) match mk_scalar sv.int_ty i with | Error _ -> Error Panic | Ok sv -> Ok (ctx, { v with V.value = V.Concrete (V.Scalar sv) })) - | (E.Not | E.Neg), Symbolic _ -> raise Unimplemented (* TODO *) | _ -> failwith "Invalid value for unop" let eval_unary_op_symbolic (config : C.config) (ctx : C.eval_ctx) (unop : E.unop) (op : E.operand) : (C.eval_ctx * V.typed_value) eval_result = - S.synthesize_unary_op unop op; - raise Unimplemented + (* Evaluate the operand *) + let ctx, v = eval_operand config ctx op in + (* Generate a fresh symbolic value to store the result *) + let ctx, res_sv_id = C.fresh_symbolic_value_id ctx in + let res_sv_ty = + match (unop, v.V.ty) with + | E.Not, T.Bool -> T.Bool + | E.Neg, T.Integer int_ty -> T.Integer int_ty + | _ -> failwith "Invalid parameters for unop" + in + let res_sv = { V.sv_id = res_sv_id; sv_ty = res_sv_ty } in + (* Synthesize *) + S.synthesize_unary_op unop v res_sv; + (* Return *) + Ok (ctx, mk_typed_value_from_symbolic_value res_sv) let eval_unary_op (config : C.config) (ctx : C.eval_ctx) (unop : E.unop) (op : E.operand) : (C.eval_ctx * V.typed_value) eval_result = diff --git a/src/InterpreterUtils.ml b/src/InterpreterUtils.ml index 4633664f..20d4c3af 100644 --- a/src/InterpreterUtils.ml +++ b/src/InterpreterUtils.ml @@ -79,6 +79,11 @@ let mk_typed_value_from_proj_comp (sv : V.symbolic_proj_comp) : V.typed_value = let value = V.Symbolic sv in { V.value; ty } +let mk_typed_value_from_symbolic_value (svalue : V.symbolic_value) : + V.typed_value = + let spc = { V.svalue; rset_ended = T.RegionId.Set.empty } in + mk_typed_value_from_proj_comp spc + let mk_aproj_loans_from_proj_comp (sv : V.symbolic_proj_comp) : V.typed_avalue = let ty = sv.V.svalue.V.sv_ty in let proj = V.AProjLoans sv.V.svalue in diff --git a/src/Synthesis.ml b/src/Synthesis.ml index 1519d0f0..aef001be 100644 --- a/src/Synthesis.ml +++ b/src/Synthesis.ml @@ -31,7 +31,9 @@ let synthesize_symbolic_expansion (sv : V.symbolic_value) (see : symbolic_expansion) : unit = () -let synthesize_unary_op (unop : E.unop) (op : E.operand) : unit = () +let synthesize_unary_op (unop : E.unop) (op : V.typed_value) + (dest : V.symbolic_value) : unit = + () let synthesize_binary_op (binop : E.binop) (op1 : E.operand) (op2 : E.operand) : unit = -- cgit v1.2.3 From dae91ffddfb90e350702e40477db37390ba17cae Mon Sep 17 00:00:00 2001 From: Son Ho Date: Wed, 5 Jan 2022 10:49:51 +0100 Subject: Implement eval_binary_op_symbolic --- src/Interpreter.ml | 51 +++++++++++++++++++++++++++++++++++++++++---------- src/Synthesis.ml | 4 ++-- 2 files changed, 43 insertions(+), 12 deletions(-) (limited to 'src') diff --git a/src/Interpreter.ml b/src/Interpreter.ml index 44bd1b9e..53f7e260 100644 --- a/src/Interpreter.ml +++ b/src/Interpreter.ml @@ -3098,7 +3098,7 @@ let eval_unary_op_concrete (config : C.config) (ctx : C.eval_ctx) match mk_scalar sv.int_ty i with | Error _ -> Error Panic | Ok sv -> Ok (ctx, { v with V.value = V.Concrete (V.Scalar sv) })) - | _ -> failwith "Invalid value for unop" + | _ -> failwith "Invalid input for unop" let eval_unary_op_symbolic (config : C.config) (ctx : C.eval_ctx) (unop : E.unop) (op : E.operand) : (C.eval_ctx * V.typed_value) eval_result @@ -3111,7 +3111,7 @@ let eval_unary_op_symbolic (config : C.config) (ctx : C.eval_ctx) match (unop, v.V.ty) with | E.Not, T.Bool -> T.Bool | E.Neg, T.Integer int_ty -> T.Integer int_ty - | _ -> failwith "Invalid parameters for unop" + | _ -> failwith "Invalid input for unop" in let res_sv = { V.sv_id = res_sv_id; sv_ty = res_sv_ty } in (* Synthesize *) @@ -3130,16 +3130,17 @@ let eval_binary_op_concrete (config : C.config) (ctx : C.eval_ctx) (C.eval_ctx * V.typed_value) eval_result = (* Evaluate the operands *) let ctx, v1, v2 = eval_two_operands config ctx op1 op2 in - if - (* Binary operations only apply on integer values, but when we check for - * equality *) - binop = Eq || binop = Ne - then ( - (* Equality/inequality check is primitive only on primitive types *) + (* Equality check binops (Eq, Ne) accept values from a wide variety of types. + * The remaining binops only operate on scalars. *) + if binop = Eq || binop = Ne then ( + (* Equality operations *) assert (v1.ty = v2.ty); + (* Equality/inequality check is primitive only for a subset of types *) + assert (type_is_primitively_copyable v1.ty); let b = v1 = v2 in Ok (ctx, { V.value = V.Concrete (Bool b); ty = T.Bool })) else + (* For the non-equality operations, the input values are necessarily scalars *) match (v1.V.value, v2.V.value) with | V.Concrete (V.Scalar sv1), V.Concrete (V.Scalar sv2) -> ( let res = @@ -3203,8 +3204,38 @@ let eval_binary_op_concrete (config : C.config) (ctx : C.eval_ctx) let eval_binary_op_symbolic (config : C.config) (ctx : C.eval_ctx) (binop : E.binop) (op1 : E.operand) (op2 : E.operand) : (C.eval_ctx * V.typed_value) eval_result = - S.synthesize_binary_op binop op1 op2; - raise Unimplemented + (* Evaluate the operands *) + let ctx, v1, v2 = eval_two_operands config ctx op1 op2 in + (* Generate a fresh symbolic value to store the result *) + let ctx, res_sv_id = C.fresh_symbolic_value_id ctx in + let res_sv_ty = + if binop = Eq || binop = Ne then ( + (* Equality operations *) + assert (v1.ty = v2.ty); + (* Equality/inequality check is primitive only for a subset of types *) + assert (type_is_primitively_copyable v1.ty); + T.Bool) + else + (* Other operations: input types are integers *) + match (v1.V.ty, v2.V.ty) with + | T.Integer int_ty1, T.Integer int_ty2 -> ( + match binop with + | E.Lt | E.Le | E.Ge | E.Gt -> + assert (int_ty1 = int_ty2); + T.Bool + | E.Div | E.Rem | E.Add | E.Sub | E.Mul | E.BitXor | E.BitAnd + | E.BitOr -> + assert (int_ty1 = int_ty2); + T.Integer int_ty1 + | E.Shl | E.Shr -> raise Unimplemented + | E.Ne | E.Eq -> failwith "Unreachable") + | _ -> failwith "Invalid inputs for binop" + in + let res_sv = { V.sv_id = res_sv_id; sv_ty = res_sv_ty } in + (* Synthesize *) + S.synthesize_binary_op binop v1 v2 res_sv; + (* Return *) + Ok (ctx, mk_typed_value_from_symbolic_value res_sv) let eval_binary_op (config : C.config) (ctx : C.eval_ctx) (binop : E.binop) (op1 : E.operand) (op2 : E.operand) : diff --git a/src/Synthesis.ml b/src/Synthesis.ml index aef001be..f3cc5f91 100644 --- a/src/Synthesis.ml +++ b/src/Synthesis.ml @@ -35,8 +35,8 @@ let synthesize_unary_op (unop : E.unop) (op : V.typed_value) (dest : V.symbolic_value) : unit = () -let synthesize_binary_op (binop : E.binop) (op1 : E.operand) (op2 : E.operand) : - unit = +let synthesize_binary_op (binop : E.binop) (op1 : V.typed_value) + (op2 : V.typed_value) (dest : V.symbolic_value) : unit = () (** Actually not sure if we need this, or a synthesize_symbolic_expansion_enum *) -- cgit v1.2.3 From 6e1e8ca15a7037dfeaa45fdc72db9eafd3c693d0 Mon Sep 17 00:00:00 2001 From: Son Ho Date: Wed, 5 Jan 2022 10:55:05 +0100 Subject: Fix some mistakes in copy_value and type_is_primitively_copyable --- src/Interpreter.ml | 12 +++++++----- 1 file changed, 7 insertions(+), 5 deletions(-) (limited to 'src') diff --git a/src/Interpreter.ml b/src/Interpreter.ml index 53f7e260..7940908c 100644 --- a/src/Interpreter.ml +++ b/src/Interpreter.ml @@ -2917,8 +2917,9 @@ let rec drop_borrows_loans_at_lplace (config : C.config) (p : E.place) *) let rec type_is_primitively_copyable (ty : T.ety) : bool = match ty with - | T.Adt (_, _, _) | T.TypeVar _ | T.Never | T.Str | T.Array _ | T.Slice _ -> - false + | T.Adt ((T.AdtId _ | T.Assumed _), _, _) -> false + | T.Adt (T.Tuple, _, tys) -> List.for_all type_is_primitively_copyable tys + | T.TypeVar _ | T.Never | T.Str | T.Array _ | T.Slice _ -> false | T.Bool | T.Char | T.Integer _ -> true | T.Ref (_, _, T.Mut) -> false | T.Ref (_, _, T.Shared) -> true @@ -2931,7 +2932,8 @@ let rec type_is_primitively_copyable (ty : T.ety) : bool = Also, this function is actually more general than it should be: it can be used to copy concrete ADT values, while ADT copy should be done through the Copy trait (i.e., by calling a dedicated function). This is why we added a parameter - to control this copy. + to control this copy. Note that here by ADT we mean the user-defined ADTs + (not tuples or assumed types). *) let rec copy_value (allow_adt_copy : bool) (config : C.config) (ctx : C.eval_ctx) (v : V.typed_value) : C.eval_ctx * V.typed_value = @@ -2942,11 +2944,11 @@ let rec copy_value (allow_adt_copy : bool) (config : C.config) match v.V.value with | V.Concrete _ -> (ctx, v) | V.Adt av -> - assert allow_adt_copy; (* Sanity check *) (match v.V.ty with | T.Adt (T.Assumed _, _, _) -> failwith "Can't copy an assumed value" - | T.Adt ((T.AdtId _ | T.Tuple), _, _) -> () (* Ok *) + | T.Adt (T.AdtId _, _, _) -> assert allow_adt_copy + | T.Adt (T.Tuple, _, _) -> () (* Ok *) | _ -> failwith "Unreachable"); let ctx, fields = List.fold_left_map -- cgit v1.2.3 From d376bd5633ed8bdd51861d5bede1888d0958d73c Mon Sep 17 00:00:00 2001 From: Son Ho Date: Wed, 5 Jan 2022 10:59:51 +0100 Subject: Change the signatures of the eval_rvalue_... functions --- src/Interpreter.ml | 29 +++++++++++++++-------------- 1 file changed, 15 insertions(+), 14 deletions(-) (limited to 'src') diff --git a/src/Interpreter.ml b/src/Interpreter.ml index 7940908c..c32e7d63 100644 --- a/src/Interpreter.ml +++ b/src/Interpreter.ml @@ -3247,7 +3247,7 @@ let eval_binary_op (config : C.config) (ctx : C.eval_ctx) (binop : E.binop) | C.SymbolicMode -> eval_binary_op_symbolic config ctx binop op1 op2 let eval_rvalue_discriminant (config : C.config) (ctx : C.eval_ctx) - (p : E.place) : (C.eval_ctx * V.typed_value) eval_result = + (p : E.place) : C.eval_ctx * V.typed_value = S.synthesize_eval_rvalue_discriminant p; (* Note that discriminant values have type `isize` *) (* Access the value *) @@ -3265,14 +3265,15 @@ let eval_rvalue_discriminant (config : C.config) (ctx : C.eval_ctx) failwith "Disciminant id out of range" (* Should really never happen *) | Ok sv -> - Ok - (ctx, { V.value = V.Concrete (V.Scalar sv); ty = Integer Isize }) - )) - | Symbolic _ -> raise Unimplemented + (ctx, { V.value = V.Concrete (V.Scalar sv); ty = Integer Isize })) + ) + | Symbolic sv -> + (* We need to perform a symbolic expansion *) + raise Unimplemented | _ -> failwith "Invalid input for `discriminant`" let eval_rvalue_ref (config : C.config) (ctx : C.eval_ctx) (p : E.place) - (bkind : E.borrow_kind) : (C.eval_ctx * V.typed_value) eval_result = + (bkind : E.borrow_kind) : C.eval_ctx * V.typed_value = S.synthesize_eval_rvalue_ref p bkind; match bkind with | E.Shared | E.TwoPhaseMut -> @@ -3305,7 +3306,7 @@ let eval_rvalue_ref (config : C.config) (ctx : C.eval_ctx) (p : E.place) (* Update the value in the context *) let ctx = write_place_unwrap config access p nv ctx in (* Return *) - Ok (ctx, rv) + (ctx, rv) | E.Mut -> (* Access the value *) let access = Write in @@ -3321,11 +3322,11 @@ let eval_rvalue_ref (config : C.config) (ctx : C.eval_ctx) (p : E.place) (* Update the value in the context *) let ctx = write_place_unwrap config access p nv ctx in (* Return *) - Ok (ctx, rv) + (ctx, rv) let eval_rvalue_aggregate (config : C.config) (ctx : C.eval_ctx) (aggregate_kind : E.aggregate_kind) (ops : E.operand list) : - (C.eval_ctx * V.typed_value) eval_result = + C.eval_ctx * V.typed_value = S.synthesize_eval_rvalue_aggregate aggregate_kind ops; (* Evaluate the operands *) let ctx, values = eval_operands config ctx ops in @@ -3335,7 +3336,7 @@ let eval_rvalue_aggregate (config : C.config) (ctx : C.eval_ctx) let tys = List.map (fun (v : V.typed_value) -> v.V.ty) values in let v = V.Adt { variant_id = None; field_values = values } in let ty = T.Adt (T.Tuple, [], tys) in - Ok (ctx, { V.value = v; ty }) + (ctx, { V.value = v; ty }) | E.AggregatedAdt (def_id, opt_variant_id, regions, types) -> (* Sanity checks *) let type_def = C.ctx_lookup_type_def ctx def_id in @@ -3352,7 +3353,7 @@ let eval_rvalue_aggregate (config : C.config) (ctx : C.eval_ctx) { V.variant_id = opt_variant_id; V.field_values = values } in let aty = T.Adt (T.AdtId def_id, regions, types) in - Ok (ctx, { V.value = Adt av; ty = aty }) + (ctx, { V.value = Adt av; ty = aty }) (** Evaluate an rvalue in a given context: return the updated context and the computed value @@ -3361,12 +3362,12 @@ let eval_rvalue (config : C.config) (ctx : C.eval_ctx) (rvalue : E.rvalue) : (C.eval_ctx * V.typed_value) eval_result = match rvalue with | E.Use op -> Ok (eval_operand config ctx op) - | E.Ref (p, bkind) -> eval_rvalue_ref config ctx p bkind + | E.Ref (p, bkind) -> Ok (eval_rvalue_ref config ctx p bkind) | E.UnaryOp (unop, op) -> eval_unary_op config ctx unop op | E.BinaryOp (binop, op1, op2) -> eval_binary_op config ctx binop op1 op2 - | E.Discriminant p -> eval_rvalue_discriminant config ctx p + | E.Discriminant p -> Ok (eval_rvalue_discriminant config ctx p) | E.Aggregate (aggregate_kind, ops) -> - eval_rvalue_aggregate config ctx aggregate_kind ops + Ok (eval_rvalue_aggregate config ctx aggregate_kind ops) (** Result of evaluating a statement *) type statement_eval_res = Unit | Break of int | Continue of int | Return -- cgit v1.2.3 From 4245b2c5df7f9da6d9374abb5613a91ef6703975 Mon Sep 17 00:00:00 2001 From: Son Ho Date: Wed, 5 Jan 2022 11:39:34 +0100 Subject: Make eval_rvalue return a list of values because of possible branchings and propagate the changes --- src/Interpreter.ml | 229 +++++++++++++++++++++++++++++++++-------------------- 1 file changed, 143 insertions(+), 86 deletions(-) (limited to 'src') diff --git a/src/Interpreter.ml b/src/Interpreter.ml index c32e7d63..d1a34e19 100644 --- a/src/Interpreter.ml +++ b/src/Interpreter.ml @@ -3247,7 +3247,7 @@ let eval_binary_op (config : C.config) (ctx : C.eval_ctx) (binop : E.binop) | C.SymbolicMode -> eval_binary_op_symbolic config ctx binop op1 op2 let eval_rvalue_discriminant (config : C.config) (ctx : C.eval_ctx) - (p : E.place) : C.eval_ctx * V.typed_value = + (p : E.place) : (C.eval_ctx * V.typed_value) list = S.synthesize_eval_rvalue_discriminant p; (* Note that discriminant values have type `isize` *) (* Access the value *) @@ -3265,8 +3265,9 @@ let eval_rvalue_discriminant (config : C.config) (ctx : C.eval_ctx) failwith "Disciminant id out of range" (* Should really never happen *) | Ok sv -> - (ctx, { V.value = V.Concrete (V.Scalar sv); ty = Integer Isize })) - ) + [ + (ctx, { V.value = V.Concrete (V.Scalar sv); ty = Integer Isize }); + ])) | Symbolic sv -> (* We need to perform a symbolic expansion *) raise Unimplemented @@ -3355,19 +3356,39 @@ let eval_rvalue_aggregate (config : C.config) (ctx : C.eval_ctx) let aty = T.Adt (T.AdtId def_id, regions, types) in (ctx, { V.value = Adt av; ty = aty }) -(** Evaluate an rvalue in a given context: return the updated context and - the computed value -*) -let eval_rvalue (config : C.config) (ctx : C.eval_ctx) (rvalue : E.rvalue) : - (C.eval_ctx * V.typed_value) eval_result = +(** Evaluate an rvalue which is not a discriminant. + + We define a function for this specific case, because evaluating + a discriminant might lead to branching (if we evaluate the discriminant + of a symbolic enumeration value), while it is not the case for the + other rvalues. + *) +let eval_rvalue_non_discriminant (config : C.config) (ctx : C.eval_ctx) + (rvalue : E.rvalue) : (C.eval_ctx * V.typed_value) eval_result = match rvalue with | E.Use op -> Ok (eval_operand config ctx op) | E.Ref (p, bkind) -> Ok (eval_rvalue_ref config ctx p bkind) | E.UnaryOp (unop, op) -> eval_unary_op config ctx unop op | E.BinaryOp (binop, op1, op2) -> eval_binary_op config ctx binop op1 op2 - | E.Discriminant p -> Ok (eval_rvalue_discriminant config ctx p) | E.Aggregate (aggregate_kind, ops) -> Ok (eval_rvalue_aggregate config ctx aggregate_kind ops) + | E.Discriminant _ -> failwith "Unreachable" + +(** Evaluate an rvalue in a given context: return the updated context and + the computed value. + + Returns a list of pairs (new context, computed rvalue) because + `discriminant` might lead to a branching in case it is applied + on a symbolic enumeration value. +*) +let eval_rvalue (config : C.config) (ctx : C.eval_ctx) (rvalue : E.rvalue) : + (C.eval_ctx * V.typed_value) list eval_result = + match rvalue with + | E.Discriminant p -> Ok (eval_rvalue_discriminant config ctx p) + | _ -> ( + match eval_rvalue_non_discriminant config ctx rvalue with + | Error e -> Error e + | Ok res -> Ok [ res ]) (** Result of evaluating a statement *) type statement_eval_res = Unit | Break of int | Continue of int | Return @@ -3428,8 +3449,7 @@ let rec end_loan_exactly_at_place (config : C.config) (access : access_kind) For instance, something like: `Cons Bottom Bottom`. *) let set_discriminant (config : C.config) (ctx : C.eval_ctx) (p : E.place) - (variant_id : T.VariantId.id) : - (C.eval_ctx * statement_eval_res) eval_result = + (variant_id : T.VariantId.id) : C.eval_ctx * statement_eval_res = S.synthesize_set_discriminant p variant_id; (* Access the value *) let access = Write in @@ -3449,7 +3469,7 @@ let set_discriminant (config : C.config) (ctx : C.eval_ctx) (p : E.place) | None -> failwith "Found a struct value while expected an enum" | Some variant_id' -> if variant_id' = variant_id then (* Nothing to do *) - Ok (ctx, Unit) + (ctx, Unit) else (* Replace the value *) let bottom_v = @@ -3457,14 +3477,14 @@ let set_discriminant (config : C.config) (ctx : C.eval_ctx) (p : E.place) def_id (Some variant_id) regions types in let ctx = write_place_unwrap config access p bottom_v ctx in - Ok (ctx, Unit)) + (ctx, Unit)) | T.Adt (T.AdtId def_id, regions, types), V.Bottom -> let bottom_v = compute_expanded_bottom_adt_value ctx.type_context.type_defs def_id (Some variant_id) regions types in let ctx = write_place_unwrap config access p bottom_v ctx in - Ok (ctx, Unit) + (ctx, Unit) | _, V.Symbolic _ -> assert (config.mode = SymbolicMode); (* TODO *) raise Unimplemented @@ -3622,7 +3642,8 @@ let eval_box_deref_mut_or_shared (config : C.config) in let borrow_kind = if is_mut then E.Mut else E.Shared in let rv = E.Ref (p, borrow_kind) in - match eval_rvalue config ctx rv with + (* Note that the rvalue can't be a discriminant value *) + match eval_rvalue_non_discriminant config ctx rv with | Error err -> Error err | Ok (ctx, borrowed_value) -> (* Move the borrowed value to its destination *) @@ -3770,7 +3791,7 @@ let eval_non_local_function_call (config : C.config) (ctx : C.eval_ctx) (** Evaluate a statement *) let rec eval_statement (config : C.config) (ctx : C.eval_ctx) (st : A.statement) - : (C.eval_ctx * statement_eval_res) eval_result = + : (C.eval_ctx * statement_eval_res) eval_result list = (* Debugging *) L.log#ldebug (lazy @@ -3783,42 +3804,52 @@ let rec eval_statement (config : C.config) (ctx : C.eval_ctx) (st : A.statement) | A.Assign (p, rvalue) -> ( (* Evaluate the rvalue *) match eval_rvalue config ctx rvalue with - | Error err -> Error err - | Ok (ctx, rvalue) -> + | Error err -> [ Error err ] + | Ok res -> (* Assign *) - let ctx = assign_to_place config ctx rvalue p in - Ok (ctx, Unit)) + let assign (ctx, rvalue) = + let ctx = assign_to_place config ctx rvalue p in + Ok (ctx, Unit) + in + List.map assign res) | A.FakeRead p -> let ctx, _ = prepare_rplace config Read p ctx in - Ok (ctx, Unit) + [ Ok (ctx, Unit) ] | A.SetDiscriminant (p, variant_id) -> - set_discriminant config ctx p variant_id - | A.Drop p -> Ok (drop_value config ctx p, Unit) + [ Ok (set_discriminant config ctx p variant_id) ] + | A.Drop p -> [ Ok (drop_value config ctx p, Unit) ] | A.Assert assertion -> ( let ctx, v = eval_operand config ctx assertion.cond in assert (v.ty = T.Bool); match v.value with | Concrete (Bool b) -> - if b = assertion.expected then Ok (ctx, Unit) else Error Panic + if b = assertion.expected then [ Ok (ctx, Unit) ] else [ Error Panic ] | _ -> failwith "Expected a boolean") | A.Call call -> eval_function_call config ctx call - | A.Panic -> Error Panic - | A.Return -> Ok (ctx, Return) - | A.Break i -> Ok (ctx, Break i) - | A.Continue i -> Ok (ctx, Continue i) - | A.Nop -> Ok (ctx, Unit) - | A.Sequence (st1, st2) -> ( + | A.Panic -> [ Error Panic ] + | A.Return -> [ Ok (ctx, Return) ] + | A.Break i -> [ Ok (ctx, Break i) ] + | A.Continue i -> [ Ok (ctx, Continue i) ] + | A.Nop -> [ Ok (ctx, Unit) ] + | A.Sequence (st1, st2) -> (* Evaluate the first statement *) - match eval_statement config ctx st1 with - | Error err -> Error err - | Ok (ctx, Unit) -> - (* Evaluate the second statement *) - eval_statement config ctx st2 - (* Control-flow break: transmit. We enumerate the cases on purpose *) - | Ok (ctx, Break i) -> Ok (ctx, Break i) - | Ok (ctx, Continue i) -> Ok (ctx, Continue i) - | Ok (ctx, Return) -> Ok (ctx, Return)) + let res1 = eval_statement config ctx st1 in + (* Evaluate the sequence *) + let eval_seq res1 = + match res1 with + | Error err -> [ Error err ] + | Ok (ctx, Unit) -> + (* Evaluate the second statement *) + eval_statement config ctx st2 + (* Control-flow break: transmit. We enumerate the cases on purpose *) + | Ok (ctx, Break i) -> [ Ok (ctx, Break i) ] + | Ok (ctx, Continue i) -> [ Ok (ctx, Continue i) ] + | Ok (ctx, Return) -> [ Ok (ctx, Return) ] + in + List.concat (List.map eval_seq res1) | A.Loop loop_body -> + (* For now, we don't support loops in symbolic mode *) + assert (config.C.mode = C.ConcreteMode); (* Evaluate a loop body We need a specific function for the [Continue] case: in case we continue, @@ -3826,28 +3857,34 @@ let rec eval_statement (config : C.config) (ctx : C.eval_ctx) (st : A.statement) (and repeat this an indefinite number of times). *) let rec eval_loop_body (ctx : C.eval_ctx) : - (C.eval_ctx * statement_eval_res) eval_result = + (C.eval_ctx * statement_eval_res) eval_result list = (* Evaluate the loop body *) - match eval_statement config ctx loop_body with - | Error err -> Error err - | Ok (ctx, Unit) -> - (* We finished evaluating the statement in a "normal" manner *) - Ok (ctx, Unit) - (* Control-flow breaks *) - | Ok (ctx, Break i) -> - (* Decrease the break index *) - if i = 0 then Ok (ctx, Unit) else Ok (ctx, Break (i - 1)) - | Ok (ctx, Continue i) -> - (* Decrease the continue index *) - if i = 0 then - (* We stop there. When we continue, we go back to the beginning - of the loop: we must thus reevaluate the loop body (and - recheck the result to know whether we must reevaluate again, - etc. *) - eval_loop_body ctx - else (* We don't stop there: transmit *) - Ok (ctx, Continue (i - 1)) - | Ok (ctx, Return) -> Ok (ctx, Return) + let body_res = eval_statement config ctx loop_body in + (* Evaluate the next steps *) + let eval res = + match res with + | Error err -> [ Error err ] + | Ok (ctx, Unit) -> + (* We finished evaluating the statement in a "normal" manner *) + [ Ok (ctx, Unit) ] + (* Control-flow breaks *) + | Ok (ctx, Break i) -> + (* Decrease the break index *) + if i = 0 then [ Ok (ctx, Unit) ] else [ Ok (ctx, Break (i - 1)) ] + | Ok (ctx, Continue i) -> + (* Decrease the continue index *) + if i = 0 then + (* We stop there. When we continue, we go back to the beginning + of the loop: we must thus reevaluate the loop body (and + recheck the result to know whether we must reevaluate again, + etc. *) + eval_loop_body ctx + else + (* We don't stop there: transmit *) + [ Ok (ctx, Continue (i - 1)) ] + | Ok (ctx, Return) -> [ Ok (ctx, Return) ] + in + List.concat (List.map eval body_res) in (* Apply *) eval_loop_body ctx @@ -3860,6 +3897,7 @@ let rec eval_statement (config : C.config) (ctx : C.eval_ctx) (st : A.statement) | V.Concrete (V.Bool b) -> if b then eval_statement config ctx st1 else eval_statement config ctx st2 + | V.Symbolic _ -> raise Unimplemented | _ -> failwith "Inconsistent state") | A.SwitchInt (int_ty, tgts, otherwise) -> ( match op_v.value with @@ -3868,11 +3906,12 @@ let rec eval_statement (config : C.config) (ctx : C.eval_ctx) (st : A.statement) match List.find_opt (fun (sv', _) -> sv = sv') tgts with | None -> eval_statement config ctx otherwise | Some (_, tgt) -> eval_statement config ctx tgt) + | V.Symbolic _ -> raise Unimplemented | _ -> failwith "Inconsistent state")) (** Evaluate a function call (auxiliary helper for [eval_statement]) *) and eval_function_call (config : C.config) (ctx : C.eval_ctx) (call : A.call) : - (C.eval_ctx * statement_eval_res) eval_result = + (C.eval_ctx * statement_eval_res) eval_result list = (* There are two cases * - this is a local function, in which case we execute its body - this is a non-local function, in which case there is a special treatment @@ -3883,22 +3922,27 @@ and eval_function_call (config : C.config) (ctx : C.eval_ctx) (call : A.call) : eval_local_function_call config ctx fid call.region_params call.type_params call.args call.dest | A.Assumed fid -> - eval_non_local_function_call config ctx fid call.region_params - call.type_params call.args call.dest + [ + eval_non_local_function_call config ctx fid call.region_params + call.type_params call.args call.dest; + ] in - match res with Error err -> Error err | Ok ctx -> Ok (ctx, Unit) + List.map + (fun res -> + match res with Error err -> Error err | Ok ctx -> Ok (ctx, Unit)) + res (** Evaluate a local (i.e, not assumed) function call (auxiliary helper for [eval_statement]) *) and eval_local_function_call (config : C.config) (ctx : C.eval_ctx) (fid : A.FunDefId.id) (region_params : T.erased_region list) (type_params : T.ety list) (args : E.operand list) (dest : E.place) : - C.eval_ctx eval_result = + C.eval_ctx eval_result list = S.synthesize_local_function_call fid region_params type_params args dest; (* Retrieve the (correctly instantiated) body *) let def = C.ctx_lookup_fun_def ctx fid in match config.mode with - | ConcreteMode -> ( + | ConcreteMode -> let tsubst = Subst.make_type_subst (List.map (fun v -> v.T.index) def.A.signature.type_params) @@ -3935,31 +3979,41 @@ and eval_local_function_call (config : C.config) (ctx : C.eval_ctx) let ctx = C.ctx_push_uninitialized_vars ctx locals in (* Execute the function body *) - match eval_function_body config ctx body with - | Error Panic -> Error Panic - | Ok ctx -> - (* Pop the stack frame and retrieve the return value *) - let ctx, ret_value = ctx_pop_frame config ctx in + let res = eval_function_body config ctx body in - (* Move the return value to its destination *) - let ctx = assign_to_place config ctx ret_value dest in + (* Pop the stack frame and move the return value to its destination *) + let finish res = + match res with + | Error Panic -> Error Panic + | Ok ctx -> + (* Pop the stack frame and retrieve the return value *) + let ctx, ret_value = ctx_pop_frame config ctx in - (* Return *) - Ok ctx) + (* Move the return value to its destination *) + let ctx = assign_to_place config ctx ret_value dest in + + (* Return *) + Ok ctx + in + List.map finish res | SymbolicMode -> raise Unimplemented (** Evaluate a statement seen as a function body (auxiliary helper for [eval_statement]) *) and eval_function_body (config : C.config) (ctx : C.eval_ctx) - (body : A.statement) : (C.eval_ctx, eval_error) result = - match eval_statement config ctx body with - | Error err -> Error err - | Ok (ctx, res) -> ( - (* Sanity check *) - if config.C.check_invariants then Inv.check_invariants ctx; - match res with - | Unit | Break _ | Continue _ -> failwith "Inconsistent state" - | Return -> Ok ctx) + (body : A.statement) : (C.eval_ctx, eval_error) result list = + let res = eval_statement config ctx body in + let finish res = + match res with + | Error err -> Error err + | Ok (ctx, res) -> ( + (* Sanity check *) + if config.C.check_invariants then Inv.check_invariants ctx; + match res with + | Unit | Break _ | Continue _ -> failwith "Inconsistent state" + | Return -> Ok ctx) + in + List.map finish res module Test = struct (** Test a unit function (taking no arguments) by evaluating it in an empty @@ -3997,8 +4051,11 @@ module Test = struct (* Evaluate the function *) let config = { C.mode = C.ConcreteMode; C.check_invariants = true } in match eval_function_body config ctx fdef.A.body with - | Error err -> Error err - | Ok _ -> Ok () + | [ Ok _ ] -> Ok () + | [ Error err ] -> Error err + | _ -> + (* We execute the concrete interpreter: there shouldn't be any branching *) + failwith "Unreachable" (** Small helper: return true if the function is a unit function (no parameters, no arguments) - TODO: move *) -- cgit v1.2.3 From f25a5619a3fde75140c20595c5b39282bbbb40e2 Mon Sep 17 00:00:00 2001 From: Son Ho Date: Wed, 5 Jan 2022 13:24:15 +0100 Subject: Implement the symbolic case of eval_rvalue_discriminant --- src/Contexts.ml | 3 +- src/Interpreter.ml | 93 ++++++++++++++++++++++++++++++++++++++++++------------ src/Synthesis.ml | 13 ++++++-- 3 files changed, 86 insertions(+), 23 deletions(-) (limited to 'src') diff --git a/src/Contexts.ml b/src/Contexts.ml index 521ea0ed..4d924a9d 100644 --- a/src/Contexts.ml +++ b/src/Contexts.ml @@ -68,7 +68,8 @@ type eval_ctx = { type_vars : type_var list; env : env; symbolic_counter : SymbolicValueId.generator; - borrow_counter : BorrowId.generator; + (* TODO: make this global? *) + borrow_counter : BorrowId.generator; (* TODO: make this global? *) } [@@deriving show] (** Evaluation context *) diff --git a/src/Interpreter.ml b/src/Interpreter.ml index d1a34e19..2fa1bea2 100644 --- a/src/Interpreter.ml +++ b/src/Interpreter.ml @@ -2522,7 +2522,7 @@ let expand_symbolic_value_shared_borrow (config : C.config) ctx in (* Update the synthesized program *) - S.synthesize_symbolic_expansion original_sv see; + S.synthesize_symbolic_expansion_no_branching original_sv see; (* Return *) ctx @@ -2554,19 +2554,21 @@ let expand_symbolic_value_borrow (config : C.config) see ctx in (* Update the synthesized program *) - S.synthesize_symbolic_expansion original_sv see; + S.synthesize_symbolic_expansion_no_branching original_sv see; (* Return *) ctx | T.Shared -> expand_symbolic_value_shared_borrow config original_sv ended_regions ref_ty ctx -(** Expand a symbolic value which is not an enumeration with several variants. +(** Expand a symbolic value which is not an enumeration with several variants + (i.e., in a situation where it doesn't lead to branching). - This function is used when exploring a path. + This function is used when exploring paths. *) -let expand_symbolic_value_non_enum (config : C.config) (pe : E.projection_elem) - (sp : V.symbolic_proj_comp) (ctx : C.eval_ctx) : C.eval_ctx = +let expand_symbolic_value_no_branching (config : C.config) + (pe : E.projection_elem) (sp : V.symbolic_proj_comp) (ctx : C.eval_ctx) : + C.eval_ctx = (* Compute the expanded value - note that when doing so, we may introduce * fresh symbolic values in the context (which thus gets updated) *) let original_sv = sp.V.svalue in @@ -2591,7 +2593,7 @@ let expand_symbolic_value_non_enum (config : C.config) (pe : E.projection_elem) apply_symbolic_expansion_non_borrow config original_sv see ctx in (* Update the synthesized program *) - S.synthesize_symbolic_expansion original_sv see; + S.synthesize_symbolic_expansion_no_branching original_sv see; (* Return *) ctx | _ -> failwith "Unexpected") @@ -2607,7 +2609,7 @@ let expand_symbolic_value_non_enum (config : C.config) (pe : E.projection_elem) apply_symbolic_expansion_non_borrow config original_sv see ctx in (* Update the synthesized program *) - S.synthesize_symbolic_expansion original_sv see; + S.synthesize_symbolic_expansion_no_branching original_sv see; (* Return *) ctx (* Boxes *) @@ -2620,7 +2622,7 @@ let expand_symbolic_value_non_enum (config : C.config) (pe : E.projection_elem) apply_symbolic_expansion_non_borrow config original_sv see ctx in (* Update the synthesized program *) - S.synthesize_symbolic_expansion original_sv see; + S.synthesize_symbolic_expansion_no_branching original_sv see; (* Return *) ctx (* Borrows *) @@ -2636,6 +2638,45 @@ let expand_symbolic_value_non_enum (config : C.config) (pe : E.projection_elem) (* Return *) ctx +(** Expand a symbolic enumeration value. + + This might lead to branching. + *) +let expand_symbolic_enum_value (config : C.config) (sp : V.symbolic_proj_comp) + (ctx : C.eval_ctx) : C.eval_ctx list = + (* Compute the expanded value - note that when doing so, we may introduce + * fresh symbolic values in the context (which thus gets updated) *) + let original_sv = sp.V.svalue in + let rty = original_sv.V.sv_ty in + let ended_regions = sp.V.rset_ended in + match rty with + (* The value should be a "regular" ADTs *) + | T.Adt (T.AdtId def_id, regions, types) -> ( + (* Compute the expanded value - there should be exactly one because we + * don't allow to expand enumerations with strictly more than one variant *) + let expand_enumerations = true in + match + compute_expanded_symbolic_adt_value expand_enumerations ended_regions + def_id regions types ctx + with + | res -> + (* Update the synthesized program *) + let seel = List.map (fun (_, x) -> x) res in + S.synthesize_symbolic_expansion_branching original_sv seel; + (* Apply in the context *) + let apply (ctx, see) : C.eval_ctx = + let ctx = + apply_symbolic_expansion_non_borrow config original_sv see ctx + in + (* Sanity check: the symbolic value has disappeared *) + assert (not (symbolic_value_id_in_ctx original_sv.V.sv_id ctx)); + (* Return *) + ctx + in + List.map apply res + | _ -> failwith "Unexpected") + | _ -> failwith "Unexpected" + (** Update the environment to be able to read a place. When reading a place, we may be stuck along the way because some value @@ -2658,7 +2699,7 @@ let rec update_ctx_along_read_place (config : C.config) (access : access_kind) activate_inactivated_mut_borrow config Outer bid ctx | FailSymbolic (pe, sp) -> (* Expand the symbolic value *) - expand_symbolic_value_non_enum config pe sp ctx + expand_symbolic_value_no_branching config pe sp ctx | FailBottom (_, _, _) -> (* We can't expand [Bottom] values while reading them *) failwith "Found [Bottom] while reading a place" @@ -2685,7 +2726,7 @@ let rec update_ctx_along_write_place (config : C.config) (access : access_kind) activate_inactivated_mut_borrow config Outer bid ctx | FailSymbolic (pe, sp) -> (* Expand the symbolic value *) - expand_symbolic_value_non_enum config pe sp ctx + expand_symbolic_value_no_branching config pe sp ctx | FailBottom (remaining_pes, pe, ty) -> (* Expand the [Bottom] value *) expand_bottom_value_from_projection config access p remaining_pes pe @@ -3246,9 +3287,9 @@ let eval_binary_op (config : C.config) (ctx : C.eval_ctx) (binop : E.binop) | C.ConcreteMode -> eval_binary_op_concrete config ctx binop op1 op2 | C.SymbolicMode -> eval_binary_op_symbolic config ctx binop op1 op2 -let eval_rvalue_discriminant (config : C.config) (ctx : C.eval_ctx) - (p : E.place) : (C.eval_ctx * V.typed_value) list = - S.synthesize_eval_rvalue_discriminant p; +(** Evaluate the discriminant of a concrete (i.e., non symbolic) ADT value *) +let eval_rvalue_discriminant_concrete (config : C.config) (p : E.place) + (ctx : C.eval_ctx) : C.eval_ctx * V.typed_value = (* Note that discriminant values have type `isize` *) (* Access the value *) let access = Read in @@ -3265,12 +3306,24 @@ let eval_rvalue_discriminant (config : C.config) (ctx : C.eval_ctx) failwith "Disciminant id out of range" (* Should really never happen *) | Ok sv -> - [ - (ctx, { V.value = V.Concrete (V.Scalar sv); ty = Integer Isize }); - ])) + (ctx, { V.value = V.Concrete (V.Scalar sv); ty = Integer Isize })) + ) + | _ -> failwith "Invalid input for `discriminant`" + +let eval_rvalue_discriminant (config : C.config) (p : E.place) + (ctx : C.eval_ctx) : (C.eval_ctx * V.typed_value) list = + S.synthesize_eval_rvalue_discriminant p; + (* Note that discriminant values have type `isize` *) + (* Access the value *) + let access = Read in + let ctx, v = prepare_rplace config access p ctx in + match v.V.value with + | Adt av -> [ eval_rvalue_discriminant_concrete config p ctx ] | Symbolic sv -> - (* We need to perform a symbolic expansion *) - raise Unimplemented + (* Expand the symbolic value - may lead to branching *) + let ctxl = expand_symbolic_enum_value config sv ctx in + (* This time the value is concrete: reevaluate *) + List.map (eval_rvalue_discriminant_concrete config p) ctxl | _ -> failwith "Invalid input for `discriminant`" let eval_rvalue_ref (config : C.config) (ctx : C.eval_ctx) (p : E.place) @@ -3384,7 +3437,7 @@ let eval_rvalue_non_discriminant (config : C.config) (ctx : C.eval_ctx) let eval_rvalue (config : C.config) (ctx : C.eval_ctx) (rvalue : E.rvalue) : (C.eval_ctx * V.typed_value) list eval_result = match rvalue with - | E.Discriminant p -> Ok (eval_rvalue_discriminant config ctx p) + | E.Discriminant p -> Ok (eval_rvalue_discriminant config p ctx) | _ -> ( match eval_rvalue_non_discriminant config ctx rvalue with | Error e -> Error e diff --git a/src/Synthesis.ml b/src/Synthesis.ml index f3cc5f91..9ce6c8da 100644 --- a/src/Synthesis.ml +++ b/src/Synthesis.ml @@ -26,11 +26,20 @@ open InterpreterUtils * `s := op1 + op2` * *) -(** TODO: rename to synthesize_symbolic_expansion_{non_enum,one_variant}? *) -let synthesize_symbolic_expansion (sv : V.symbolic_value) +(** Synthesize code for a symbolic expansion which doesn't lead to branching + (i.e., applied on a value which is not an enumeration with several variants). + *) +let synthesize_symbolic_expansion_no_branching (sv : V.symbolic_value) (see : symbolic_expansion) : unit = () +(** Synthesize code for a symbolic expansion which leads to branching + (for instance when evaluating the discriminant of a symbolic value). + *) +let synthesize_symbolic_expansion_branching (sv : V.symbolic_value) + (seel : symbolic_expansion list) : unit = + () + let synthesize_unary_op (unop : E.unop) (op : V.typed_value) (dest : V.symbolic_value) : unit = () -- cgit v1.2.3 From 07619853cdee8079dcba2e01912cd0b905f21dce Mon Sep 17 00:00:00 2001 From: Son Ho Date: Wed, 5 Jan 2022 13:29:38 +0100 Subject: Implement the symbolic case of set_discriminant --- src/Interpreter.ml | 9 ++++++++- 1 file changed, 8 insertions(+), 1 deletion(-) (limited to 'src') diff --git a/src/Interpreter.ml b/src/Interpreter.ml index 2fa1bea2..5db49935 100644 --- a/src/Interpreter.ml +++ b/src/Interpreter.ml @@ -3540,7 +3540,14 @@ let set_discriminant (config : C.config) (ctx : C.eval_ctx) (p : E.place) (ctx, Unit) | _, V.Symbolic _ -> assert (config.mode = SymbolicMode); - (* TODO *) raise Unimplemented + (* This is a bit annoying: in theory we should expand the symbolic value + * then set the discriminant, because in the case the discriminant is + * exactly the one we set, the fields are left untouched, and in the + * other cases they are set to Bottom. + * For now, we forbid setting the discriminant of a symbolic value: + * setting a discriminant should only be used to initialize a value, + * really. *) + failwith "Unexpected value" | _, (V.Adt _ | V.Bottom) -> failwith "Inconsistent state" | _, (V.Concrete _ | V.Borrow _ | V.Loan _) -> failwith "Unexpected value" -- cgit v1.2.3 From e8bedd70f1c2fe86f856c0516e713874928b8b3b Mon Sep 17 00:00:00 2001 From: Son Ho Date: Wed, 5 Jan 2022 13:31:08 +0100 Subject: Cleanup a bit --- src/Interpreter.ml | 38 ++++++++++++++++++-------------------- 1 file changed, 18 insertions(+), 20 deletions(-) (limited to 'src') diff --git a/src/Interpreter.ml b/src/Interpreter.ml index 5db49935..3d3d7129 100644 --- a/src/Interpreter.ml +++ b/src/Interpreter.ml @@ -2651,30 +2651,28 @@ let expand_symbolic_enum_value (config : C.config) (sp : V.symbolic_proj_comp) let ended_regions = sp.V.rset_ended in match rty with (* The value should be a "regular" ADTs *) - | T.Adt (T.AdtId def_id, regions, types) -> ( + | T.Adt (T.AdtId def_id, regions, types) -> (* Compute the expanded value - there should be exactly one because we * don't allow to expand enumerations with strictly more than one variant *) let expand_enumerations = true in - match + let res = compute_expanded_symbolic_adt_value expand_enumerations ended_regions def_id regions types ctx - with - | res -> - (* Update the synthesized program *) - let seel = List.map (fun (_, x) -> x) res in - S.synthesize_symbolic_expansion_branching original_sv seel; - (* Apply in the context *) - let apply (ctx, see) : C.eval_ctx = - let ctx = - apply_symbolic_expansion_non_borrow config original_sv see ctx - in - (* Sanity check: the symbolic value has disappeared *) - assert (not (symbolic_value_id_in_ctx original_sv.V.sv_id ctx)); - (* Return *) - ctx - in - List.map apply res - | _ -> failwith "Unexpected") + in + (* Update the synthesized program *) + let seel = List.map (fun (_, x) -> x) res in + S.synthesize_symbolic_expansion_branching original_sv seel; + (* Apply in the context *) + let apply (ctx, see) : C.eval_ctx = + let ctx = + apply_symbolic_expansion_non_borrow config original_sv see ctx + in + (* Sanity check: the symbolic value has disappeared *) + assert (not (symbolic_value_id_in_ctx original_sv.V.sv_id ctx)); + (* Return *) + ctx + in + List.map apply res | _ -> failwith "Unexpected" (** Update the environment to be able to read a place. @@ -3318,7 +3316,7 @@ let eval_rvalue_discriminant (config : C.config) (p : E.place) let access = Read in let ctx, v = prepare_rplace config access p ctx in match v.V.value with - | Adt av -> [ eval_rvalue_discriminant_concrete config p ctx ] + | Adt _ -> [ eval_rvalue_discriminant_concrete config p ctx ] | Symbolic sv -> (* Expand the symbolic value - may lead to branching *) let ctxl = expand_symbolic_enum_value config sv ctx in -- cgit v1.2.3 From d6b659f90735818dcc1fbeb92da9d74a5de2f495 Mon Sep 17 00:00:00 2001 From: Son Ho Date: Wed, 5 Jan 2022 13:51:55 +0100 Subject: Start working on the symbolic case of switch evaluation --- src/Interpreter.ml | 94 +++++++++++++++++++++++++++++++++++++++++++----------- 1 file changed, 75 insertions(+), 19 deletions(-) (limited to 'src') diff --git a/src/Interpreter.ml b/src/Interpreter.ml index 3d3d7129..5bcd4cac 100644 --- a/src/Interpreter.ml +++ b/src/Interpreter.ml @@ -3080,6 +3080,26 @@ let prepare_rplace (config : C.config) (access : access_kind) (p : E.place) let v = read_place_unwrap config access p ctx in (ctx, v) +(** Prepare the evaluation of an operand. *) +let eval_operand_prepare (config : C.config) (ctx : C.eval_ctx) (op : E.operand) + : C.eval_ctx * V.typed_value = + let ctx, v = + match op with + | Expressions.Constant (ty, cv) -> + let v = constant_value_to_typed_value ctx ty cv in + (ctx, v) + | Expressions.Copy p -> + (* Access the value *) + let access = Read in + prepare_rplace config access p ctx + | Expressions.Move p -> + (* Access the value *) + let access = Move in + prepare_rplace config access p ctx + in + assert (not (bottom_in_value v)); + (ctx, v) + (** Evaluate an operand. *) let eval_operand (config : C.config) (ctx : C.eval_ctx) (op : E.operand) : C.eval_ctx * V.typed_value = @@ -3847,6 +3867,15 @@ let eval_non_local_function_call (config : C.config) (ctx : C.eval_ctx) (* Return *) Ok ctx) +(** Expand a symbolic value over which we perform a switch *) +let expand_symbolic_switch_scrutinee (config : C.config) (ctx : C.eval_ctx) + (sv : V.symbolic_proj_comp) (tgts : A.switch_targets) : C.eval_ctx list = + (* (* Expand, depending on the switch kind *) + match tgts with + | A.If (_, _) -> + | A.SwitchInt (int_ty, tgts, otherwise) ->*) + raise Unimplemented + (** Evaluate a statement *) let rec eval_statement (config : C.config) (ctx : C.eval_ctx) (st : A.statement) : (C.eval_ctx * statement_eval_res) eval_result list = @@ -3947,25 +3976,52 @@ let rec eval_statement (config : C.config) (ctx : C.eval_ctx) (st : A.statement) (* Apply *) eval_loop_body ctx | A.Switch (op, tgts) -> ( - (* Evaluate the operand *) - let ctx, op_v = eval_operand config ctx op in - match tgts with - | A.If (st1, st2) -> ( - match op_v.value with - | V.Concrete (V.Bool b) -> - if b then eval_statement config ctx st1 - else eval_statement config ctx st2 - | V.Symbolic _ -> raise Unimplemented - | _ -> failwith "Inconsistent state") - | A.SwitchInt (int_ty, tgts, otherwise) -> ( - match op_v.value with - | V.Concrete (V.Scalar sv) -> ( - assert (sv.V.int_ty = int_ty); - match List.find_opt (fun (sv', _) -> sv = sv') tgts with - | None -> eval_statement config ctx otherwise - | Some (_, tgt) -> eval_statement config ctx tgt) - | V.Symbolic _ -> raise Unimplemented - | _ -> failwith "Inconsistent state")) + (* We evaluate the operand in two steps: + * first we prepare it, then we check if its value is concrete or + * symbolic. If it is concrete, we can then evaluate the operand + * directly, otherwise we must first expand the value. + * Note that we can't fully evaluate the operand *then* expand the + * value if it is symbolic, because the value may have been move + * (and thus floating in thin air...)! + * *) + (* Prepare the operand *) + let ctx, op_v = eval_operand_prepare config ctx op in + (* Check if the operand is concrete or symbolic, expand it if necessary *) + match op_v.V.value with + | V.Symbolic sv -> + (* Expand the symbolic value *) + let ctxl = expand_symbolic_switch_scrutinee config ctx sv tgts in + (* The value under scrutinee is now concrete: we can evaluate the switch *) + List.concat (List.map (eval_switch_concrete config op tgts) ctxl) + | _ -> + (* Concrete *) + eval_switch_concrete config op tgts ctx) + +(** Evaluate a switch *over* a concrete value. + + The caller must make sure to expand the value under scrutinee *before* + calling this function, if the value is symbolic. +*) +and eval_switch_concrete (config : C.config) (op : E.operand) + (tgts : A.switch_targets) (ctx : C.eval_ctx) : + (C.eval_ctx * statement_eval_res) eval_result list = + (* Evaluate the operand *) + let ctx, op_v = eval_operand config ctx op in + match tgts with + | A.If (st1, st2) -> ( + match op_v.value with + | V.Concrete (V.Bool b) -> + if b then eval_statement config ctx st1 + else eval_statement config ctx st2 + | _ -> failwith "Inconsistent state") + | A.SwitchInt (int_ty, tgts, otherwise) -> ( + match op_v.value with + | V.Concrete (V.Scalar sv) -> ( + assert (sv.V.int_ty = int_ty); + match List.find_opt (fun (sv', _) -> sv = sv') tgts with + | None -> eval_statement config ctx otherwise + | Some (_, tgt) -> eval_statement config ctx tgt) + | _ -> failwith "Inconsistent state") (** Evaluate a function call (auxiliary helper for [eval_statement]) *) and eval_function_call (config : C.config) (ctx : C.eval_ctx) (call : A.call) : -- cgit v1.2.3 From 57a019c4b18d4f9a695f4520dd33d482abde3d5f Mon Sep 17 00:00:00 2001 From: Son Ho Date: Wed, 5 Jan 2022 14:25:48 +0100 Subject: Finish implementing the symbolic case of switch evaluation --- src/Interpreter.ml | 114 +++++++++++++++++++++++++++++++++-------------------- src/Synthesis.ml | 12 ++++-- 2 files changed, 81 insertions(+), 45 deletions(-) (limited to 'src') diff --git a/src/Interpreter.ml b/src/Interpreter.ml index 5bcd4cac..970ef3a6 100644 --- a/src/Interpreter.ml +++ b/src/Interpreter.ml @@ -2661,7 +2661,7 @@ let expand_symbolic_enum_value (config : C.config) (sp : V.symbolic_proj_comp) in (* Update the synthesized program *) let seel = List.map (fun (_, x) -> x) res in - S.synthesize_symbolic_expansion_branching original_sv seel; + S.synthesize_symbolic_expansion_enum_branching original_sv seel; (* Apply in the context *) let apply (ctx, see) : C.eval_ctx = let ctx = @@ -3867,15 +3867,6 @@ let eval_non_local_function_call (config : C.config) (ctx : C.eval_ctx) (* Return *) Ok ctx) -(** Expand a symbolic value over which we perform a switch *) -let expand_symbolic_switch_scrutinee (config : C.config) (ctx : C.eval_ctx) - (sv : V.symbolic_proj_comp) (tgts : A.switch_targets) : C.eval_ctx list = - (* (* Expand, depending on the switch kind *) - match tgts with - | A.If (_, _) -> - | A.SwitchInt (int_ty, tgts, otherwise) ->*) - raise Unimplemented - (** Evaluate a statement *) let rec eval_statement (config : C.config) (ctx : C.eval_ctx) (st : A.statement) : (C.eval_ctx * statement_eval_res) eval_result list = @@ -3975,52 +3966,91 @@ let rec eval_statement (config : C.config) (ctx : C.eval_ctx) (st : A.statement) in (* Apply *) eval_loop_body ctx - | A.Switch (op, tgts) -> ( - (* We evaluate the operand in two steps: - * first we prepare it, then we check if its value is concrete or - * symbolic. If it is concrete, we can then evaluate the operand - * directly, otherwise we must first expand the value. - * Note that we can't fully evaluate the operand *then* expand the - * value if it is symbolic, because the value may have been move - * (and thus floating in thin air...)! - * *) - (* Prepare the operand *) - let ctx, op_v = eval_operand_prepare config ctx op in - (* Check if the operand is concrete or symbolic, expand it if necessary *) - match op_v.V.value with - | V.Symbolic sv -> - (* Expand the symbolic value *) - let ctxl = expand_symbolic_switch_scrutinee config ctx sv tgts in - (* The value under scrutinee is now concrete: we can evaluate the switch *) - List.concat (List.map (eval_switch_concrete config op tgts) ctxl) - | _ -> - (* Concrete *) - eval_switch_concrete config op tgts ctx) - -(** Evaluate a switch *over* a concrete value. - - The caller must make sure to expand the value under scrutinee *before* - calling this function, if the value is symbolic. -*) -and eval_switch_concrete (config : C.config) (op : E.operand) - (tgts : A.switch_targets) (ctx : C.eval_ctx) : - (C.eval_ctx * statement_eval_res) eval_result list = - (* Evaluate the operand *) - let ctx, op_v = eval_operand config ctx op in + | A.Switch (op, tgts) -> eval_switch config op tgts ctx + +(** Evaluate a switch *) +and eval_switch (config : C.config) (op : E.operand) (tgts : A.switch_targets) + (ctx : C.eval_ctx) : (C.eval_ctx * statement_eval_res) eval_result list = + (* We evaluate the operand in two steps: + * first we prepare it, then we check if its value is concrete or + * symbolic. If it is concrete, we can then evaluate the operand + * directly, otherwise we must first expand the value. + * Note that we can't fully evaluate the operand *then* expand the + * value if it is symbolic, because the value may have been move + * (and would thus floating in thin air...)! + * *) + (* Prepare the operand *) + let ctx, op_v = eval_operand_prepare config ctx op in + (* Match on the targets *) match tgts with | A.If (st1, st2) -> ( match op_v.value with | V.Concrete (V.Bool b) -> + (* Evaluate the operand *) + let ctx, op_v' = eval_operand config ctx op in + assert (op_v' = op_v); + (* Branch *) if b then eval_statement config ctx st1 else eval_statement config ctx st2 + | V.Symbolic sv -> + (* Synthesis *) + S.synthesize_symbolic_expansion_if_branching sv.V.svalue; + (* Expand the symbolic value to true or false *) + let see_true = SeConcrete (V.Bool true) in + let see_false = SeConcrete (V.Bool false) in + let expand_and_execute see st = + (* Apply the symbolic expansion *) + let ctx = + apply_symbolic_expansion_non_borrow config sv.V.svalue see ctx + in + (* Evaluate the operand *) + let ctx, _ = eval_operand config ctx op in + (* Evaluate the branch *) + eval_statement config ctx st + in + (* Execute the two branches *) + List.append + (expand_and_execute see_true st1) + (expand_and_execute see_false st2) | _ -> failwith "Inconsistent state") | A.SwitchInt (int_ty, tgts, otherwise) -> ( match op_v.value with | V.Concrete (V.Scalar sv) -> ( + (* Evaluate the operand *) + let ctx, op_v' = eval_operand config ctx op in + assert (op_v' = op_v); + (* Sanity check *) assert (sv.V.int_ty = int_ty); + (* Find the branch *) match List.find_opt (fun (sv', _) -> sv = sv') tgts with | None -> eval_statement config ctx otherwise | Some (_, tgt) -> eval_statement config ctx tgt) + | V.Symbolic sv -> + (* Synthesis *) + S.synthesize_symbolic_expansion_switch_int_branching sv.V.svalue; + (* For all the branches of the switch, we expand the symbolic value + * to the value given by the branch and execute the branch statement. + * For the otherwise branch, we leave the symbolic value as it is + * (because this branch doesn't precisely define which should be the + * value of the scrutinee...) and simply execute the otherwise statement. + *) + (* Branches other than "otherwise" *) + let exec_branch (switch_value, branch_st) = + let see = SeConcrete (V.Scalar switch_value) in + (* Apply the symbolic expansion *) + let ctx = + apply_symbolic_expansion_non_borrow config sv.V.svalue see ctx + in + (* Evaluate the operand *) + let ctx, _ = eval_operand config ctx op in + (* Evaluate the branch *) + eval_statement config ctx branch_st + in + let ctxl = List.map exec_branch tgts in + (* Otherwise branch *) + let ctx_otherwise = eval_statement config ctx otherwise in + (* Put everything together *) + List.append (List.concat ctxl) ctx_otherwise | _ -> failwith "Inconsistent state") (** Evaluate a function call (auxiliary helper for [eval_statement]) *) diff --git a/src/Synthesis.ml b/src/Synthesis.ml index 9ce6c8da..51aa0882 100644 --- a/src/Synthesis.ml +++ b/src/Synthesis.ml @@ -33,13 +33,19 @@ let synthesize_symbolic_expansion_no_branching (sv : V.symbolic_value) (see : symbolic_expansion) : unit = () -(** Synthesize code for a symbolic expansion which leads to branching - (for instance when evaluating the discriminant of a symbolic value). +(** Synthesize code for a symbolic enum expansion (which leads to branching) *) -let synthesize_symbolic_expansion_branching (sv : V.symbolic_value) +let synthesize_symbolic_expansion_enum_branching (sv : V.symbolic_value) (seel : symbolic_expansion list) : unit = () +let synthesize_symbolic_expansion_if_branching (sv : V.symbolic_value) : unit = + () + +let synthesize_symbolic_expansion_switch_int_branching (sv : V.symbolic_value) : + unit = + () + let synthesize_unary_op (unop : E.unop) (op : V.typed_value) (dest : V.symbolic_value) : unit = () -- cgit v1.2.3 From 9f2f2340d5679dbd8219fdc7f026f80e1b3811c1 Mon Sep 17 00:00:00 2001 From: Son Ho Date: Wed, 5 Jan 2022 14:35:12 +0100 Subject: Remove synthesize_set_discriminant --- src/Interpreter.ml | 1 - src/Synthesis.ml | 4 ---- 2 files changed, 5 deletions(-) (limited to 'src') diff --git a/src/Interpreter.ml b/src/Interpreter.ml index 970ef3a6..482a3623 100644 --- a/src/Interpreter.ml +++ b/src/Interpreter.ml @@ -3521,7 +3521,6 @@ let rec end_loan_exactly_at_place (config : C.config) (access : access_kind) *) let set_discriminant (config : C.config) (ctx : C.eval_ctx) (p : E.place) (variant_id : T.VariantId.id) : C.eval_ctx * statement_eval_res = - S.synthesize_set_discriminant p variant_id; (* Access the value *) let access = Write in let ctx = update_ctx_along_read_place config access p ctx in diff --git a/src/Synthesis.ml b/src/Synthesis.ml index 51aa0882..dce40470 100644 --- a/src/Synthesis.ml +++ b/src/Synthesis.ml @@ -63,10 +63,6 @@ let synthesize_eval_rvalue_aggregate (aggregate_kind : E.aggregate_kind) (ops : E.operand list) : unit = () -let synthesize_set_discriminant (p : E.place) (variant_id : T.VariantId.id) : - unit = - () - let synthesize_non_local_function_call (fid : A.assumed_fun_id) (region_params : T.erased_region list) (type_params : T.ety list) (args : E.operand list) (dest : E.place) : unit = -- cgit v1.2.3 From f4666616e5bbfe56a0e770c541567c605161b131 Mon Sep 17 00:00:00 2001 From: Son Ho Date: Wed, 5 Jan 2022 16:14:40 +0100 Subject: Update the code to deserialize regions_hierarchy information --- src/CfimAst.ml | 19 +++++++++++++++++++ src/CfimOfJson.ml | 17 +++++++++++++++++ 2 files changed, 36 insertions(+) (limited to 'src') diff --git a/src/CfimAst.ml b/src/CfimAst.ml index 250cd223..28f23758 100644 --- a/src/CfimAst.ml +++ b/src/CfimAst.ml @@ -5,6 +5,8 @@ open Expressions module FunDefId = IdGen () +module RegionGroupId = IdGen () + type var = { index : VarId.id; (** Unique variable identifier *) name : string option; @@ -24,9 +26,26 @@ type fun_id = Local of FunDefId.id | Assumed of assumed_fun_id type assertion = { cond : operand; expected : bool } [@@deriving show] +type region_group = { + id : RegionGroupId.id; + regions : RegionVarId.id list; + parents : RegionGroupId.id list; +} +[@@deriving show] +(** A group of regions. + + Results from a lifetime analysis: we group the regions with the same + lifetime together, and compute the hierarchy between the regions. + This is necessary to introduce the proper abstraction with the + proper constraints, when evaluating a function call in symbolic mode. +*) + +type region_groups = region_group list [@@deriving show] + type fun_sig = { region_params : region_var list; num_early_bound_regions : int; + regions_hierarchy : region_groups; type_params : type_var list; inputs : sty list; output : sty; diff --git a/src/CfimOfJson.ml b/src/CfimOfJson.ml index 3494f004..4f39d7ff 100644 --- a/src/CfimOfJson.ml +++ b/src/CfimOfJson.ml @@ -436,6 +436,20 @@ let assertion_of_json (js : json) : (A.assertion, string) result = Ok { A.cond; expected } | _ -> Error "") +let region_group_of_json (js : json) : (A.region_group, string) result = + combine_error_msgs js "region_group_of_json" + (match js with + | `Assoc [ ("id", id); ("regions", regions); ("parents", parents) ] -> + let* id = A.RegionGroupId.id_of_json id in + let* regions = list_of_json T.RegionVarId.id_of_json regions in + let* parents = list_of_json A.RegionGroupId.id_of_json parents in + Ok { A.id; regions; parents } + | _ -> Error "") + +let region_groups_of_json (js : json) : (A.region_groups, string) result = + combine_error_msgs js "region_group_of_json" + (list_of_json region_group_of_json js) + let fun_sig_of_json (js : json) : (A.fun_sig, string) result = combine_error_msgs js "fun_sig_of_json" (match js with @@ -443,12 +457,14 @@ let fun_sig_of_json (js : json) : (A.fun_sig, string) result = [ ("region_params", region_params); ("num_early_bound_regions", num_early_bound_regions); + ("regions_hierarchy", regions_hierarchy); ("type_params", type_params); ("inputs", inputs); ("output", output); ] -> let* region_params = list_of_json region_var_of_json region_params in let* num_early_bound_regions = int_of_json num_early_bound_regions in + let* regions_hierarchy = region_groups_of_json regions_hierarchy in let* type_params = list_of_json type_var_of_json type_params in let* inputs = list_of_json sty_of_json inputs in let* output = sty_of_json output in @@ -456,6 +472,7 @@ let fun_sig_of_json (js : json) : (A.fun_sig, string) result = { A.region_params; num_early_bound_regions; + regions_hierarchy; type_params; inputs; output; -- cgit v1.2.3 From 8904a6daf444082a26172ad3187f9d61420ab8ec Mon Sep 17 00:00:00 2001 From: Son Ho Date: Wed, 5 Jan 2022 16:42:24 +0100 Subject: Prepare the terrain for evaluation of function calls in symbolic mode --- src/Contexts.ml | 4 +- src/Interpreter.ml | 184 ++++++++++++++++++++++++++++++++--------------------- 2 files changed, 114 insertions(+), 74 deletions(-) (limited to 'src') diff --git a/src/Contexts.ml b/src/Contexts.ml index 4d924a9d..fec1e11b 100644 --- a/src/Contexts.ml +++ b/src/Contexts.ml @@ -69,7 +69,9 @@ type eval_ctx = { env : env; symbolic_counter : SymbolicValueId.generator; (* TODO: make this global? *) - borrow_counter : BorrowId.generator; (* TODO: make this global? *) + borrow_counter : BorrowId.generator; + (* TODO: make this global? *) + abstraction_counter : AbstractionId.generator; (* TODO: make this global? *) } [@@deriving show] (** Evaluation context *) diff --git a/src/Interpreter.ml b/src/Interpreter.ml index 482a3623..00821668 100644 --- a/src/Interpreter.ml +++ b/src/Interpreter.ml @@ -3781,31 +3781,11 @@ let eval_box_free (config : C.config) (region_params : T.erased_region list) Ok ctx | _ -> failwith "Inconsistent state" -(** Evaluate a non-local (i.e, assumed) function call such as `Box::deref` - (auxiliary helper for [eval_statement]) *) -let eval_non_local_function_call (config : C.config) (ctx : C.eval_ctx) +(** Evaluate a non-local function call in concrete mode *) +let eval_non_local_function_call_concrete (config : C.config) (ctx : C.eval_ctx) (fid : A.assumed_fun_id) (region_params : T.erased_region list) (type_params : T.ety list) (args : E.operand list) (dest : E.place) : C.eval_ctx eval_result = - (* Debug *) - L.log#ldebug - (lazy - (let type_params = - "[" - ^ String.concat ", " (List.map (ety_to_string ctx) type_params) - ^ "]" - in - let args = - "[" ^ String.concat ", " (List.map (operand_to_string ctx) args) ^ "]" - in - let dest = place_to_string ctx dest in - "eval_non_local_function_call:\n- fid:" ^ A.show_assumed_fun_id fid - ^ "\n- type_params: " ^ type_params ^ "\n- args: " ^ args ^ "\n- dest: " - ^ dest)); - - (* Synthesis *) - S.synthesize_non_local_function_call fid region_params type_params args dest; - (* There are two cases (and this is extremely annoying): - the function is not box_free - the function is box_free @@ -3866,6 +3846,46 @@ let eval_non_local_function_call (config : C.config) (ctx : C.eval_ctx) (* Return *) Ok ctx) +(** Evaluate a non-local function call in concrete mode *) +let eval_non_local_function_call_symbolic (config : C.config) (ctx : C.eval_ctx) + (fid : A.assumed_fun_id) (region_params : T.erased_region list) + (type_params : T.ety list) (args : E.operand list) (dest : E.place) : + C.eval_ctx eval_result = + (* Synthesis *) + S.synthesize_non_local_function_call fid region_params type_params args dest; + + raise Unimplemented + +(** Evaluate a non-local (i.e, assumed) function call such as `Box::deref` + (auxiliary helper for [eval_statement]) *) +let eval_non_local_function_call (config : C.config) (ctx : C.eval_ctx) + (fid : A.assumed_fun_id) (region_params : T.erased_region list) + (type_params : T.ety list) (args : E.operand list) (dest : E.place) : + C.eval_ctx eval_result = + (* Debug *) + L.log#ldebug + (lazy + (let type_params = + "[" + ^ String.concat ", " (List.map (ety_to_string ctx) type_params) + ^ "]" + in + let args = + "[" ^ String.concat ", " (List.map (operand_to_string ctx) args) ^ "]" + in + let dest = place_to_string ctx dest in + "eval_non_local_function_call:\n- fid:" ^ A.show_assumed_fun_id fid + ^ "\n- type_params: " ^ type_params ^ "\n- args: " ^ args ^ "\n- dest: " + ^ dest)); + + match config.mode with + | C.ConcreteMode -> + eval_non_local_function_call_concrete config ctx fid region_params + type_params args dest + | C.SymbolicMode -> + eval_non_local_function_call_symbolic config ctx fid region_params + type_params args dest + (** Evaluate a statement *) let rec eval_statement (config : C.config) (ctx : C.eval_ctx) (st : A.statement) : (C.eval_ctx * statement_eval_res) eval_result list = @@ -4075,71 +4095,88 @@ and eval_function_call (config : C.config) (ctx : C.eval_ctx) (call : A.call) : match res with Error err -> Error err | Ok ctx -> Ok (ctx, Unit)) res -(** Evaluate a local (i.e, not assumed) function call (auxiliary helper for - [eval_statement]) *) -and eval_local_function_call (config : C.config) (ctx : C.eval_ctx) +(** Evaluate a local (i.e., non-assumed) function call in concrete mode *) +and eval_local_function_call_concrete (config : C.config) (ctx : C.eval_ctx) (fid : A.FunDefId.id) (region_params : T.erased_region list) (type_params : T.ety list) (args : E.operand list) (dest : E.place) : C.eval_ctx eval_result list = - S.synthesize_local_function_call fid region_params type_params args dest; (* Retrieve the (correctly instantiated) body *) let def = C.ctx_lookup_fun_def ctx fid in - match config.mode with - | ConcreteMode -> - let tsubst = - Subst.make_type_subst - (List.map (fun v -> v.T.index) def.A.signature.type_params) - type_params - in - let locals, body = Subst.fun_def_substitute_in_body tsubst def in + let tsubst = + Subst.make_type_subst + (List.map (fun v -> v.T.index) def.A.signature.type_params) + type_params + in + let locals, body = Subst.fun_def_substitute_in_body tsubst def in - (* Evaluate the input operands *) - let ctx, args = eval_operands config ctx args in - assert (List.length args = def.A.arg_count); + (* Evaluate the input operands *) + let ctx, args = eval_operands config ctx args in + assert (List.length args = def.A.arg_count); - (* Push a frame delimiter *) - let ctx = ctx_push_frame ctx in + (* Push a frame delimiter *) + let ctx = ctx_push_frame ctx in - (* Compute the initial values for the local variables *) - (* 1. Push the return value *) - let ret_var, locals = - match locals with - | ret_ty :: locals -> (ret_ty, locals) - | _ -> failwith "Unreachable" - in - let ctx = C.ctx_push_var ctx ret_var (C.mk_bottom ret_var.var_ty) in + (* Compute the initial values for the local variables *) + (* 1. Push the return value *) + let ret_var, locals = + match locals with + | ret_ty :: locals -> (ret_ty, locals) + | _ -> failwith "Unreachable" + in + let ctx = C.ctx_push_var ctx ret_var (C.mk_bottom ret_var.var_ty) in - (* 2. Push the input values *) - let input_locals, locals = - Utilities.list_split_at locals def.A.arg_count - in - let inputs = List.combine input_locals args in - (* Note that this function checks that the variables and their values - have the same type (this is important) *) - let ctx = C.ctx_push_vars ctx inputs in + (* 2. Push the input values *) + let input_locals, locals = Utilities.list_split_at locals def.A.arg_count in + let inputs = List.combine input_locals args in + (* Note that this function checks that the variables and their values + have the same type (this is important) *) + let ctx = C.ctx_push_vars ctx inputs in - (* 3. Push the remaining local variables (initialized as [Bottom]) *) - let ctx = C.ctx_push_uninitialized_vars ctx locals in + (* 3. Push the remaining local variables (initialized as [Bottom]) *) + let ctx = C.ctx_push_uninitialized_vars ctx locals in - (* Execute the function body *) - let res = eval_function_body config ctx body in + (* Execute the function body *) + let res = eval_function_body config ctx body in - (* Pop the stack frame and move the return value to its destination *) - let finish res = - match res with - | Error Panic -> Error Panic - | Ok ctx -> - (* Pop the stack frame and retrieve the return value *) - let ctx, ret_value = ctx_pop_frame config ctx in + (* Pop the stack frame and move the return value to its destination *) + let finish res = + match res with + | Error Panic -> Error Panic + | Ok ctx -> + (* Pop the stack frame and retrieve the return value *) + let ctx, ret_value = ctx_pop_frame config ctx in - (* Move the return value to its destination *) - let ctx = assign_to_place config ctx ret_value dest in + (* Move the return value to its destination *) + let ctx = assign_to_place config ctx ret_value dest in - (* Return *) - Ok ctx - in - List.map finish res - | SymbolicMode -> raise Unimplemented + (* Return *) + Ok ctx + in + List.map finish res + +(** Evaluate a local (i.e., non-assumed) function call in symbolic mode *) +and eval_local_function_call_symbolic (config : C.config) (ctx : C.eval_ctx) + (fid : A.FunDefId.id) (region_params : T.erased_region list) + (type_params : T.ety list) (args : E.operand list) (dest : E.place) : + C.eval_ctx eval_result list = + raise Unimplemented + +(** Evaluate a local (i.e, not assumed) function call (auxiliary helper for + [eval_statement]) *) +and eval_local_function_call (config : C.config) (ctx : C.eval_ctx) + (fid : A.FunDefId.id) (region_params : T.erased_region list) + (type_params : T.ety list) (args : E.operand list) (dest : E.place) : + C.eval_ctx eval_result list = + S.synthesize_local_function_call fid region_params type_params args dest; + (* Retrieve the (correctly instantiated) body *) + let def = C.ctx_lookup_fun_def ctx fid in + match config.mode with + | ConcreteMode -> + eval_local_function_call_concrete config ctx fid region_params type_params + args dest + | SymbolicMode -> + eval_local_function_call_symbolic config ctx fid region_params type_params + args dest (** Evaluate a statement seen as a function body (auxiliary helper for [eval_statement]) *) @@ -4185,6 +4222,7 @@ module Test = struct C.env = []; C.symbolic_counter = V.SymbolicValueId.generator_zero; C.borrow_counter = V.BorrowId.generator_zero; + C.abstraction_counter = V.AbstractionId.generator_zero; } in -- cgit v1.2.3 From b191de7f680e4ae43178fc42ccabc91808e189f8 Mon Sep 17 00:00:00 2001 From: Son Ho Date: Wed, 5 Jan 2022 18:13:06 +0100 Subject: Make good progress on eval_local_function_call_symbolic --- src/CfimAst.ml | 33 +++++++++++++++++++----- src/CfimOfJson.ml | 13 +++++----- src/Contexts.ml | 10 ++++++++ src/Interpreter.ml | 73 ++++++++++++++++++++++++++++++++++++++++++++++++++---- src/Substitute.ml | 50 +++++++++++++++++++++++++++++++++++++ src/Synthesis.ml | 2 +- src/Types.ml | 7 ++++-- src/TypesUtils.ml | 22 ++++++++++++++++ src/Values.ml | 2 +- 9 files changed, 191 insertions(+), 21 deletions(-) (limited to 'src') diff --git a/src/CfimAst.ml b/src/CfimAst.ml index 28f23758..23c8f1aa 100644 --- a/src/CfimAst.ml +++ b/src/CfimAst.ml @@ -26,10 +26,10 @@ type fun_id = Local of FunDefId.id | Assumed of assumed_fun_id type assertion = { cond : operand; expected : bool } [@@deriving show] -type region_group = { - id : RegionGroupId.id; - regions : RegionVarId.id list; - parents : RegionGroupId.id list; +type ('id, 'r) g_region_group = { + id : 'id; + regions : 'r list; + parents : 'id list; } [@@deriving show] (** A group of regions. @@ -40,17 +40,38 @@ type region_group = { proper constraints, when evaluating a function call in symbolic mode. *) -type region_groups = region_group list [@@deriving show] +type ('r, 'id) g_region_groups = ('r, 'id) g_region_group list [@@deriving show] + +type region_var_group = (RegionGroupId.id, RegionVarId.id) g_region_group +[@@deriving show] + +type region_var_groups = (RegionGroupId.id, RegionVarId.id) g_region_groups +[@@deriving show] + +type abs_region_group = (AbstractionId.id, RegionId.id) g_region_group +[@@deriving show] + +type abs_region_groups = (AbstractionId.id, RegionId.id) g_region_groups +[@@deriving show] type fun_sig = { region_params : region_var list; num_early_bound_regions : int; - regions_hierarchy : region_groups; + regions_hierarchy : region_var_groups; type_params : type_var list; inputs : sty list; output : sty; } [@@deriving show] +(** A function signature, as used when declaring functions *) + +type inst_fun_sig = { + regions_hierarchy : abs_region_groups; + inputs : rty list; + output : rty; +} +[@@deriving show] +(** A function signature, after instantiation *) type call = { func : fun_id; diff --git a/src/CfimOfJson.ml b/src/CfimOfJson.ml index 4f39d7ff..a1dd0ad1 100644 --- a/src/CfimOfJson.ml +++ b/src/CfimOfJson.ml @@ -436,8 +436,8 @@ let assertion_of_json (js : json) : (A.assertion, string) result = Ok { A.cond; expected } | _ -> Error "") -let region_group_of_json (js : json) : (A.region_group, string) result = - combine_error_msgs js "region_group_of_json" +let region_var_group_of_json (js : json) : (A.region_var_group, string) result = + combine_error_msgs js "region_var_group_of_json" (match js with | `Assoc [ ("id", id); ("regions", regions); ("parents", parents) ] -> let* id = A.RegionGroupId.id_of_json id in @@ -446,9 +446,10 @@ let region_group_of_json (js : json) : (A.region_group, string) result = Ok { A.id; regions; parents } | _ -> Error "") -let region_groups_of_json (js : json) : (A.region_groups, string) result = - combine_error_msgs js "region_group_of_json" - (list_of_json region_group_of_json js) +let region_var_groups_of_json (js : json) : (A.region_var_groups, string) result + = + combine_error_msgs js "region_var_group_of_json" + (list_of_json region_var_group_of_json js) let fun_sig_of_json (js : json) : (A.fun_sig, string) result = combine_error_msgs js "fun_sig_of_json" @@ -464,7 +465,7 @@ let fun_sig_of_json (js : json) : (A.fun_sig, string) result = ] -> let* region_params = list_of_json region_var_of_json region_params in let* num_early_bound_regions = int_of_json num_early_bound_regions in - let* regions_hierarchy = region_groups_of_json regions_hierarchy in + let* regions_hierarchy = region_var_groups_of_json regions_hierarchy in let* type_params = list_of_json type_var_of_json type_params in let* inputs = list_of_json sty_of_json inputs in let* output = sty_of_json output in diff --git a/src/Contexts.ml b/src/Contexts.ml index fec1e11b..89056680 100644 --- a/src/Contexts.ml +++ b/src/Contexts.ml @@ -71,6 +71,8 @@ type eval_ctx = { (* TODO: make this global? *) borrow_counter : BorrowId.generator; (* TODO: make this global? *) + region_counter : RegionId.generator; + (* TODO: make this global? *) abstraction_counter : AbstractionId.generator; (* TODO: make this global? *) } [@@deriving show] @@ -84,6 +86,14 @@ let fresh_borrow_id (ctx : eval_ctx) : eval_ctx * BorrowId.id = let id, counter' = BorrowId.fresh ctx.borrow_counter in ({ ctx with borrow_counter = counter' }, id) +let fresh_region_id (ctx : eval_ctx) : eval_ctx * RegionId.id = + let id, counter' = RegionId.fresh ctx.region_counter in + ({ ctx with region_counter = counter' }, id) + +let fresh_abstraction_id (ctx : eval_ctx) : eval_ctx * AbstractionId.id = + let id, counter' = AbstractionId.fresh ctx.abstraction_counter in + ({ ctx with abstraction_counter = counter' }, id) + let lookup_type_var (ctx : eval_ctx) (vid : TypeVarId.id) : type_var = TypeVarId.nth ctx.type_vars vid diff --git a/src/Interpreter.ml b/src/Interpreter.ml index 00821668..ed5c52d3 100644 --- a/src/Interpreter.ml +++ b/src/Interpreter.ml @@ -4158,8 +4158,68 @@ and eval_local_function_call_concrete (config : C.config) (ctx : C.eval_ctx) and eval_local_function_call_symbolic (config : C.config) (ctx : C.eval_ctx) (fid : A.FunDefId.id) (region_params : T.erased_region list) (type_params : T.ety list) (args : E.operand list) (dest : E.place) : - C.eval_ctx eval_result list = - raise Unimplemented + C.eval_ctx = + (* Retrieve the (correctly instantiated) signature *) + let def = C.ctx_lookup_fun_def ctx fid in + let sg = def.A.signature in + (* Generate fresh abstraction ids and create a substitution from region + * group ids to abstraction ids *) + let ctx, rg_abs_ids_bindings = + List.fold_left_map + (fun ctx rg -> + let ctx, abs_id = C.fresh_abstraction_id ctx in + (ctx, (rg.A.id, abs_id))) + ctx sg.regions_hierarchy + in + let asubst_map : V.AbstractionId.id A.RegionGroupId.Map.t = + List.fold_left + (fun mp (rg_id, abs_id) -> A.RegionGroupId.Map.add rg_id abs_id mp) + A.RegionGroupId.Map.empty rg_abs_ids_bindings + in + let asubst (rg_id : A.RegionGroupId.id) : V.AbstractionId.id = + A.RegionGroupId.Map.find rg_id asubst_map + in + (* Generate fresh regions and their substitutions *) + let ctx, fresh_regions, rsubst, _ = + Subst.fresh_regions_with_substs sg.region_params ctx + in + (* Generate the type substitution + * Note that we need the substitution to map the type variables to + * [rty] types (not [ety]). In order to do that, we convert the + * type parameters to types with regions. This is possible only + * if those types don't contain any regions. + * This is a current limitation of the analysis: there is still some + * work to do to properly handle full type parametrization. + * *) + let rtype_params = List.map ety_no_regions_to_rty type_params in + let tsubst = + Subst.make_type_subst + (List.map (fun v -> v.T.index) sg.type_params) + rtype_params + in + (* Substitute the signature *) + let inst_sg = Subst.substitute_signature asubst rsubst tsubst sg in + (* Generate a fresh symbolic value for the result *) + let res_sv_ty = inst_sg.A.output in + let ctx, res_sv = + mk_fresh_symbolic_proj_comp T.RegionId.Set.empty res_sv_ty ctx + in + (* Generate the abstractions from the region groups *) + let generate_abs (ctx : C.eval_ctx) (rg : A.abs_region_group) : + C.eval_ctx * V.abs = + raise Unimplemented + in + let ctx, abs = + List.fold_left_map generate_abs ctx inst_sg.A.regions_hierarchy + in + (* Add the abstractions to the context *) + let abs = List.rev (List.map (fun abs -> C.Abs abs) abs) in + let ctx = { ctx with C.env = List.append abs ctx.C.env } in + (* Synthesis *) + S.synthesize_local_function_call fid region_params type_params args dest + res_sv.V.svalue; + (* Return *) + ctx (** Evaluate a local (i.e, not assumed) function call (auxiliary helper for [eval_statement]) *) @@ -4167,7 +4227,6 @@ and eval_local_function_call (config : C.config) (ctx : C.eval_ctx) (fid : A.FunDefId.id) (region_params : T.erased_region list) (type_params : T.ety list) (args : E.operand list) (dest : E.place) : C.eval_ctx eval_result list = - S.synthesize_local_function_call fid region_params type_params args dest; (* Retrieve the (correctly instantiated) body *) let def = C.ctx_lookup_fun_def ctx fid in match config.mode with @@ -4175,8 +4234,11 @@ and eval_local_function_call (config : C.config) (ctx : C.eval_ctx) eval_local_function_call_concrete config ctx fid region_params type_params args dest | SymbolicMode -> - eval_local_function_call_symbolic config ctx fid region_params type_params - args dest + [ + Ok + (eval_local_function_call_symbolic config ctx fid region_params + type_params args dest); + ] (** Evaluate a statement seen as a function body (auxiliary helper for [eval_statement]) *) @@ -4222,6 +4284,7 @@ module Test = struct C.env = []; C.symbolic_counter = V.SymbolicValueId.generator_zero; C.borrow_counter = V.BorrowId.generator_zero; + C.region_counter = T.RegionId.generator_zero; C.abstraction_counter = V.AbstractionId.generator_zero; } in diff --git a/src/Substitute.ml b/src/Substitute.ml index 81b0ec7e..dd89025b 100644 --- a/src/Substitute.ml +++ b/src/Substitute.ml @@ -35,6 +35,38 @@ let rec ty_substitute (rsubst : 'r1 -> 'r2) let erase_regions (ty : T.rty) : T.ety = ty_substitute (fun _ -> T.Erased) (fun vid -> T.TypeVar vid) ty +(** Generate fresh regions for region variables. + + Return the list of new regions and appropriate substitutions from the + original region variables to the fresh regions. + *) +let fresh_regions_with_substs (region_vars : T.region_var list) + (ctx : C.eval_ctx) : + C.eval_ctx + * T.RegionId.id list + * (T.RegionVarId.id -> T.RegionId.id) + * (T.RegionVarId.id T.region -> T.RegionId.id T.region) = + (* Generate fresh regions *) + let ctx, fresh_region_ids = + List.fold_left_map (fun ctx _ -> C.fresh_region_id ctx) ctx region_vars + in + let fresh_regions = List.map (fun rid -> T.Var rid) fresh_region_ids in + (* Generate the map from region var ids to regions *) + let ls = List.combine region_vars fresh_region_ids in + let rid_map = + List.fold_left + (fun mp (k, v) -> T.RegionVarId.Map.add k.T.index v mp) + T.RegionVarId.Map.empty ls + in + (* Generate the substitution from region var id to region *) + let rid_subst id = T.RegionVarId.Map.find id rid_map in + (* Generate the substitution from region to region *) + let rsubst r = + match r with T.Static -> T.Static | T.Var id -> T.Var (rid_subst id) + in + (* Return *) + (ctx, fresh_region_ids, rid_subst, rsubst) + (** Erase the regions in a type and substitute the type variables *) let erase_regions_substitute_types (tsubst : T.TypeVarId.id -> T.ety) (ty : 'r T.region T.ty) : T.ety = @@ -292,3 +324,21 @@ let fun_def_substitute_in_body (tsubst : T.TypeVarId.id -> T.ety) in let body = statement_substitute tsubst def.body in (locals, body) + +(** Substitute a function signature *) +let substitute_signature (asubst : A.RegionGroupId.id -> V.AbstractionId.id) + (rsubst : T.RegionVarId.id -> T.RegionId.id) + (tsubst : T.TypeVarId.id -> T.rty) (sg : A.fun_sig) : A.inst_fun_sig = + let rsubst' (r : T.RegionVarId.id T.region) : T.RegionId.id T.region = + match r with T.Static -> T.Static | T.Var rid -> T.Var (rsubst rid) + in + let inputs = List.map (ty_substitute rsubst' tsubst) sg.A.inputs in + let output = ty_substitute rsubst' tsubst sg.A.output in + let subst_region_group (rg : A.region_var_group) : A.abs_region_group = + let id = asubst rg.A.id in + let regions = List.map rsubst rg.A.regions in + let parents = List.map asubst rg.A.parents in + { A.id; regions; parents } + in + let regions_hierarchy = List.map subst_region_group sg.A.regions_hierarchy in + { A.regions_hierarchy; inputs; output } diff --git a/src/Synthesis.ml b/src/Synthesis.ml index dce40470..f317a5f9 100644 --- a/src/Synthesis.ml +++ b/src/Synthesis.ml @@ -70,5 +70,5 @@ let synthesize_non_local_function_call (fid : A.assumed_fun_id) let synthesize_local_function_call (fid : A.FunDefId.id) (region_params : T.erased_region list) (type_params : T.ety list) - (args : E.operand list) (dest : E.place) : unit = + (args : E.operand list) (dest : E.place) (res : V.symbolic_value) : unit = () diff --git a/src/Types.ml b/src/Types.ml index 8b2b0bd9..b33df0ac 100644 --- a/src/Types.ml +++ b/src/Types.ml @@ -135,13 +135,16 @@ type 'r ty = }] (* TODO: group Bool, Char, etc. in Constant *) -type sty = RegionVarId.id region ty [@@deriving show] +type 'r gr_ty = 'r region ty [@@deriving show] +(** Generic type with regions *) + +type sty = RegionVarId.id gr_ty [@@deriving show] (** *S*ignature types. Used in function signatures and type definitions. *) -type rty = RegionId.id region ty [@@deriving show] +type rty = RegionId.id gr_ty [@@deriving show] (** Type with *R*egions. Used during symbolic execution. diff --git a/src/TypesUtils.ml b/src/TypesUtils.ml index 9741004c..4b3d8b0f 100644 --- a/src/TypesUtils.ml +++ b/src/TypesUtils.ml @@ -21,3 +21,25 @@ let ty_is_unit (ty : 'r ty) : bool = (** The unit type *) let mk_unit_ty : ety = Adt (Tuple, [], []) + +(** Convert an [ety], containing no region variables, to an [rty]. + + In practice, it is the identity. + *) +let rec ety_no_regions_to_rty (ty : ety) : rty = + match ty with + | Adt (type_id, regions, tys) -> + assert (regions = []); + Adt (type_id, [], List.map ety_no_regions_to_rty tys) + | TypeVar v -> TypeVar v + | Bool -> Bool + | Char -> Char + | Never -> Never + | Integer int_ty -> Integer int_ty + | Str -> Str + | Array ty -> Array (ety_no_regions_to_rty ty) + | Slice ty -> Slice (ety_no_regions_to_rty ty) + | Ref (_, _, _) -> + failwith + "Can't convert a ref with erased regions to a ref with non-erased \ + regions" diff --git a/src/Values.ml b/src/Values.ml index 0239da5e..001c0347 100644 --- a/src/Values.ml +++ b/src/Values.ml @@ -544,7 +544,7 @@ type abs = { parents : (AbstractionId.set_t[@opaque]); (** The parent abstractions *) acc_regions : (RegionId.set_t[@opaque]); (** Union of the regions owned by the (transitive) parent abstractions and - by the current abstraction *) + by the current abstraction. TODO: why do we need those? *) regions : (RegionId.set_t[@opaque]); (** Regions owned by this abstraction *) avalues : typed_avalue list; (** The values in this abstraction *) } -- cgit v1.2.3 From d22f5d1ae5155c53b9cd0daf165dccb5d5563c1f Mon Sep 17 00:00:00 2001 From: Son Ho Date: Wed, 5 Jan 2022 18:36:47 +0100 Subject: Finish implementing eval_local_function_call_symbolic --- src/Interpreter.ml | 59 ++++++++++++++++++++++++++++++++++++++++++++---------- src/Synthesis.ml | 3 ++- src/Values.ml | 3 --- 3 files changed, 50 insertions(+), 15 deletions(-) (limited to 'src') diff --git a/src/Interpreter.ml b/src/Interpreter.ml index ed5c52d3..2192c491 100644 --- a/src/Interpreter.ml +++ b/src/Interpreter.ml @@ -442,6 +442,11 @@ let symbolic_expansion_non_borrow_to_value (sv : V.symbolic_value) in { V.value; V.ty } +let apply_proj_borrows_in_context (check_symbolic_no_ended : bool) + (ctx : C.eval_ctx) (regions : T.RegionId.set_t) (v : V.typed_value) + (ty : T.rty) : C.eval_ctx * V.typed_avalue = + raise Unimplemented + (** Convert a symbolic expansion to a value. If the expansion is a mutable reference expansion, it converts it to a borrow. @@ -4201,23 +4206,55 @@ and eval_local_function_call_symbolic (config : C.config) (ctx : C.eval_ctx) let inst_sg = Subst.substitute_signature asubst rsubst tsubst sg in (* Generate a fresh symbolic value for the result *) let res_sv_ty = inst_sg.A.output in - let ctx, res_sv = + let ctx, res_spc = mk_fresh_symbolic_proj_comp T.RegionId.Set.empty res_sv_ty ctx in - (* Generate the abstractions from the region groups *) - let generate_abs (ctx : C.eval_ctx) (rg : A.abs_region_group) : - C.eval_ctx * V.abs = - raise Unimplemented + let res_value = mk_typed_value_from_proj_comp res_spc in + let res_av = V.ASymbolic (V.AProjLoans res_spc.V.svalue) in + let res_av : V.typed_avalue = + { V.value = res_av; V.ty = res_spc.V.svalue.V.sv_ty } in - let ctx, abs = - List.fold_left_map generate_abs ctx inst_sg.A.regions_hierarchy + (* Evaluate the input operands *) + let ctx, args = eval_operands config ctx args in + assert (List.length args = def.A.arg_count); + let args_with_rtypes = List.combine args rtype_params in + (* Generate the abstractions from the region groups and add them to the context *) + let gen_abs (ctx : C.eval_ctx) (rg : A.abs_region_group) : C.eval_ctx = + let abs_id = rg.A.id in + let parents = + List.fold_left + (fun s pid -> V.AbstractionId.Set.add pid s) + V.AbstractionId.Set.empty rg.A.parents + in + let regions = + List.fold_left + (fun s rid -> T.RegionId.Set.add rid s) + T.RegionId.Set.empty rg.A.regions + in + (* Project over the input values *) + let check_symbolic_no_ended = true in + let ctx, args_projs = + List.fold_left_map + (fun ctx (arg, arg_rty) -> + apply_proj_borrows_in_context check_symbolic_no_ended ctx regions arg + arg_rty) + ctx args_with_rtypes + in + (* Group the input and output values *) + let avalues = List.append args_projs [ res_av ] in + (* Create the abstraction *) + let abs = { V.abs_id; parents; regions; avalues } in + (* Insert the abstraction in the context *) + let ctx = { ctx with env = Abs abs :: ctx.env } in + (* Return *) + ctx in - (* Add the abstractions to the context *) - let abs = List.rev (List.map (fun abs -> C.Abs abs) abs) in - let ctx = { ctx with C.env = List.append abs ctx.C.env } in + let ctx = List.fold_left gen_abs ctx inst_sg.A.regions_hierarchy in + (* Move the return value to its destination *) + let ctx = assign_to_place config ctx res_value dest in (* Synthesis *) S.synthesize_local_function_call fid region_params type_params args dest - res_sv.V.svalue; + res_spc.V.svalue; (* Return *) ctx diff --git a/src/Synthesis.ml b/src/Synthesis.ml index f317a5f9..60c387d2 100644 --- a/src/Synthesis.ml +++ b/src/Synthesis.ml @@ -70,5 +70,6 @@ let synthesize_non_local_function_call (fid : A.assumed_fun_id) let synthesize_local_function_call (fid : A.FunDefId.id) (region_params : T.erased_region list) (type_params : T.ety list) - (args : E.operand list) (dest : E.place) (res : V.symbolic_value) : unit = + (args : V.typed_value list) (dest : E.place) (res : V.symbolic_value) : unit + = () diff --git a/src/Values.ml b/src/Values.ml index 001c0347..ae9eb127 100644 --- a/src/Values.ml +++ b/src/Values.ml @@ -542,9 +542,6 @@ and typed_avalue = { value : avalue; ty : rty } type abs = { abs_id : (AbstractionId.id[@opaque]); parents : (AbstractionId.set_t[@opaque]); (** The parent abstractions *) - acc_regions : (RegionId.set_t[@opaque]); - (** Union of the regions owned by the (transitive) parent abstractions and - by the current abstraction. TODO: why do we need those? *) regions : (RegionId.set_t[@opaque]); (** Regions owned by this abstraction *) avalues : typed_avalue list; (** The values in this abstraction *) } -- cgit v1.2.3 From eb16147150d72642c6dc86ee2427b5378bf3f140 Mon Sep 17 00:00:00 2001 From: Son Ho Date: Wed, 5 Jan 2022 18:38:53 +0100 Subject: Cleanup a bit --- src/Interpreter.ml | 26 ++++++++++++-------------- src/Substitute.ml | 2 ++ 2 files changed, 14 insertions(+), 14 deletions(-) (limited to 'src') diff --git a/src/Interpreter.ml b/src/Interpreter.ml index 2192c491..f753206c 100644 --- a/src/Interpreter.ml +++ b/src/Interpreter.ml @@ -4185,7 +4185,7 @@ and eval_local_function_call_symbolic (config : C.config) (ctx : C.eval_ctx) A.RegionGroupId.Map.find rg_id asubst_map in (* Generate fresh regions and their substitutions *) - let ctx, fresh_regions, rsubst, _ = + let ctx, _, rsubst, _ = Subst.fresh_regions_with_substs sg.region_params ctx in (* Generate the type substitution @@ -4204,15 +4204,15 @@ and eval_local_function_call_symbolic (config : C.config) (ctx : C.eval_ctx) in (* Substitute the signature *) let inst_sg = Subst.substitute_signature asubst rsubst tsubst sg in - (* Generate a fresh symbolic value for the result *) - let res_sv_ty = inst_sg.A.output in - let ctx, res_spc = - mk_fresh_symbolic_proj_comp T.RegionId.Set.empty res_sv_ty ctx + (* Generate a fresh symbolic value for the return value *) + let ret_sv_ty = inst_sg.A.output in + let ctx, ret_spc = + mk_fresh_symbolic_proj_comp T.RegionId.Set.empty ret_sv_ty ctx in - let res_value = mk_typed_value_from_proj_comp res_spc in - let res_av = V.ASymbolic (V.AProjLoans res_spc.V.svalue) in - let res_av : V.typed_avalue = - { V.value = res_av; V.ty = res_spc.V.svalue.V.sv_ty } + let ret_value = mk_typed_value_from_proj_comp ret_spc in + let ret_av = V.ASymbolic (V.AProjLoans ret_spc.V.svalue) in + let ret_av : V.typed_avalue = + { V.value = ret_av; V.ty = ret_spc.V.svalue.V.sv_ty } in (* Evaluate the input operands *) let ctx, args = eval_operands config ctx args in @@ -4241,7 +4241,7 @@ and eval_local_function_call_symbolic (config : C.config) (ctx : C.eval_ctx) ctx args_with_rtypes in (* Group the input and output values *) - let avalues = List.append args_projs [ res_av ] in + let avalues = List.append args_projs [ ret_av ] in (* Create the abstraction *) let abs = { V.abs_id; parents; regions; avalues } in (* Insert the abstraction in the context *) @@ -4251,10 +4251,10 @@ and eval_local_function_call_symbolic (config : C.config) (ctx : C.eval_ctx) in let ctx = List.fold_left gen_abs ctx inst_sg.A.regions_hierarchy in (* Move the return value to its destination *) - let ctx = assign_to_place config ctx res_value dest in + let ctx = assign_to_place config ctx ret_value dest in (* Synthesis *) S.synthesize_local_function_call fid region_params type_params args dest - res_spc.V.svalue; + ret_spc.V.svalue; (* Return *) ctx @@ -4264,8 +4264,6 @@ and eval_local_function_call (config : C.config) (ctx : C.eval_ctx) (fid : A.FunDefId.id) (region_params : T.erased_region list) (type_params : T.ety list) (args : E.operand list) (dest : E.place) : C.eval_ctx eval_result list = - (* Retrieve the (correctly instantiated) body *) - let def = C.ctx_lookup_fun_def ctx fid in match config.mode with | ConcreteMode -> eval_local_function_call_concrete config ctx fid region_params type_params diff --git a/src/Substitute.ml b/src/Substitute.ml index dd89025b..d3c3c430 100644 --- a/src/Substitute.ml +++ b/src/Substitute.ml @@ -39,6 +39,8 @@ let erase_regions (ty : T.rty) : T.ety = Return the list of new regions and appropriate substitutions from the original region variables to the fresh regions. + + TODO: simplify? we only need the subst `T.RegionVarId.id -> T.RegionId.id` *) let fresh_regions_with_substs (region_vars : T.region_var list) (ctx : C.eval_ctx) : -- cgit v1.2.3 From 5c0bf06ba5248f9d428452cd4d0654259e6fe80d Mon Sep 17 00:00:00 2001 From: Son Ho Date: Wed, 5 Jan 2022 19:02:26 +0100 Subject: Make progress on implementing the symbolic evaluation for the non-local function calls --- src/Interpreter.ml | 133 ++++++++++++++++++++++++++++++++---------------- src/InterpreterUtils.ml | 8 +-- src/TypesUtils.ml | 45 ++++++++++++++++ 3 files changed, 134 insertions(+), 52 deletions(-) (limited to 'src') diff --git a/src/Interpreter.ml b/src/Interpreter.ml index f753206c..0adff0dc 100644 --- a/src/Interpreter.ml +++ b/src/Interpreter.ml @@ -12,6 +12,7 @@ open ValuesUtils module Inv = Invariants open InterpreterUtils module S = Synthesis +open Utils (* TODO: check that the value types are correct when evaluating *) (* TODO: for debugging purposes, we might want to put use eval_ctx everywhere @@ -74,33 +75,6 @@ let get_first_loan_in_value (v : V.typed_value) : V.loan_content option = None with FoundLoanContent lc -> Some lc -(** Check if a region is in a set of regions *) -let region_in_set (r : T.RegionId.id T.region) (rset : T.RegionId.set_t) : bool - = - match r with T.Static -> false | T.Var id -> T.RegionId.Set.mem id rset - -(** Return the set of regions in an rty *) -let rty_regions (ty : T.rty) : T.RegionId.set_t = - let s = ref T.RegionId.Set.empty in - let add_region (r : T.RegionId.id T.region) = - match r with T.Static -> () | T.Var rid -> s := T.RegionId.Set.add rid !s - in - let obj = - object - inherit [_] T.iter_ty - - method! visit_'r _env r = add_region r - end - in - (* Explore the type *) - obj#visit_ty () ty; - (* Return the set of accumulated regions *) - !s - -let rty_regions_intersect (ty : T.rty) (regions : T.RegionId.set_t) : bool = - let ty_regions = rty_regions ty in - not (T.RegionId.Set.disjoint ty_regions regions) - (** Check if two different projections intersect. This is necessary when giving a symbolic value to an abstraction: we need to check that the regions which are already ended inside the abstraction don't @@ -3667,8 +3641,9 @@ let assign_to_place (config : C.config) (ctx : C.eval_ctx) (v : V.typed_value) ctx (** Auxiliary function - see [eval_non_local_function_call] *) -let eval_box_new (config : C.config) (region_params : T.erased_region list) - (type_params : T.ety list) (ctx : C.eval_ctx) : C.eval_ctx eval_result = +let eval_box_new_concrete (config : C.config) + (region_params : T.erased_region list) (type_params : T.ety list) + (ctx : C.eval_ctx) : C.eval_ctx eval_result = (* Check and retrieve the arguments *) match (region_params, type_params, ctx.env) with | ( [], @@ -3700,7 +3675,7 @@ let eval_box_new (config : C.config) (region_params : T.erased_region list) (** Auxiliary function which factorizes code to evaluate `std::Deref::deref` and `std::DerefMut::deref_mut` - see [eval_non_local_function_call] *) -let eval_box_deref_mut_or_shared (config : C.config) +let eval_box_deref_mut_or_shared_concrete (config : C.config) (region_params : T.erased_region list) (type_params : T.ety list) (is_mut : bool) (ctx : C.eval_ctx) : C.eval_ctx eval_result = (* Check the arguments *) @@ -3735,17 +3710,20 @@ let eval_box_deref_mut_or_shared (config : C.config) | _ -> failwith "Inconsistent state" (** Auxiliary function - see [eval_non_local_function_call] *) -let eval_box_deref (config : C.config) (region_params : T.erased_region list) - (type_params : T.ety list) (ctx : C.eval_ctx) : C.eval_ctx eval_result = +let eval_box_deref_concrete (config : C.config) + (region_params : T.erased_region list) (type_params : T.ety list) + (ctx : C.eval_ctx) : C.eval_ctx eval_result = let is_mut = false in - eval_box_deref_mut_or_shared config region_params type_params is_mut ctx + eval_box_deref_mut_or_shared_concrete config region_params type_params is_mut + ctx (** Auxiliary function - see [eval_non_local_function_call] *) -let eval_box_deref_mut (config : C.config) +let eval_box_deref_mut_concrete (config : C.config) (region_params : T.erased_region list) (type_params : T.ety list) (ctx : C.eval_ctx) : C.eval_ctx eval_result = let is_mut = true in - eval_box_deref_mut_or_shared config region_params type_params is_mut ctx + eval_box_deref_mut_or_shared_concrete config region_params type_params is_mut + ctx (** Auxiliary function - see [eval_non_local_function_call]. @@ -3768,7 +3746,7 @@ let eval_box_deref_mut (config : C.config) *) let eval_box_free (config : C.config) (region_params : T.erased_region list) (type_params : T.ety list) (args : E.operand list) (dest : E.place) - (ctx : C.eval_ctx) : C.eval_ctx eval_result = + (ctx : C.eval_ctx) : C.eval_ctx = match (region_params, type_params, args) with | [], [ boxed_ty ], [ E.Move input_box_place ] -> (* Required type checking *) @@ -3783,9 +3761,38 @@ let eval_box_free (config : C.config) (region_params : T.erased_region list) let ctx = assign_to_place config ctx mk_unit_value dest in (* Return *) - Ok ctx + ctx | _ -> failwith "Inconsistent state" +(** Auxiliary function - see [eval_non_local_function_call] *) +let eval_box_new_symbolic (config : C.config) + (region_params : T.erased_region list) (type_params : T.ety list) + (ctx : C.eval_ctx) : C.eval_ctx * V.typed_value = + raise Unimplemented + +(** Auxiliary function which factorizes code to evaluate `std::Deref::deref` + and `std::DerefMut::deref_mut` - see [eval_non_local_function_call] *) +let eval_box_deref_mut_or_shared_symbolic (config : C.config) + (region_params : T.erased_region list) (type_params : T.ety list) + (is_mut : bool) (ctx : C.eval_ctx) : C.eval_ctx * V.typed_value = + raise Unimplemented + +(** Auxiliary function - see [eval_non_local_function_call] *) +let eval_box_deref_symbolic (config : C.config) + (region_params : T.erased_region list) (type_params : T.ety list) + (ctx : C.eval_ctx) : C.eval_ctx * V.typed_value = + let is_mut = false in + eval_box_deref_mut_or_shared_symbolic config region_params type_params is_mut + ctx + +(** Auxiliary function - see [eval_non_local_function_call] *) +let eval_box_deref_mut_symbolic (config : C.config) + (region_params : T.erased_region list) (type_params : T.ety list) + (ctx : C.eval_ctx) : C.eval_ctx * V.typed_value = + let is_mut = true in + eval_box_deref_mut_or_shared_symbolic config region_params type_params is_mut + ctx + (** Evaluate a non-local function call in concrete mode *) let eval_non_local_function_call_concrete (config : C.config) (ctx : C.eval_ctx) (fid : A.assumed_fun_id) (region_params : T.erased_region list) @@ -3799,7 +3806,7 @@ let eval_non_local_function_call_concrete (config : C.config) (ctx : C.eval_ctx) match fid with | A.BoxFree -> (* Degenerate case: box_free *) - eval_box_free config region_params type_params args dest ctx + Ok (eval_box_free config region_params type_params args dest ctx) | _ -> ( (* "Normal" case: not box_free *) (* Evaluate the operands *) @@ -3830,10 +3837,11 @@ let eval_non_local_function_call_concrete (config : C.config) (ctx : C.eval_ctx) access to a body. *) let res = match fid with - | A.BoxNew -> eval_box_new config region_params type_params ctx - | A.BoxDeref -> eval_box_deref config region_params type_params ctx + | A.BoxNew -> eval_box_new_concrete config region_params type_params ctx + | A.BoxDeref -> + eval_box_deref_concrete config region_params type_params ctx | A.BoxDerefMut -> - eval_box_deref_mut config region_params type_params ctx + eval_box_deref_mut_concrete config region_params type_params ctx | A.BoxFree -> failwith "Unreachable" (* should have been treated above *) in @@ -3855,11 +3863,45 @@ let eval_non_local_function_call_concrete (config : C.config) (ctx : C.eval_ctx) let eval_non_local_function_call_symbolic (config : C.config) (ctx : C.eval_ctx) (fid : A.assumed_fun_id) (region_params : T.erased_region list) (type_params : T.ety list) (args : E.operand list) (dest : E.place) : - C.eval_ctx eval_result = + C.eval_ctx = (* Synthesis *) S.synthesize_non_local_function_call fid region_params type_params args dest; - raise Unimplemented + (* Sanity check: make sure the type parameters don't contain regions - + * this is a current limitation of our synthesis *) + assert (List.for_all (fun ty -> not (ty_has_regions ty)) type_params); + + (* There are two cases (and this is extremely annoying): + - the function is not box_free + - the function is box_free + See [eval_box_free] + *) + match fid with + | A.BoxFree -> + (* Degenerate case: box_free *) + eval_box_free config region_params type_params args dest ctx + | _ -> + (* "Normal" case: not box_free *) + (* Evaluate the operands *) + let ctx, args_vl = eval_operands config ctx args in + + (* Evaluate the function call *) + let ctx, ret_value = + match fid with + | A.BoxNew -> eval_box_new_symbolic config region_params type_params ctx + | A.BoxDeref -> + eval_box_deref_symbolic config region_params type_params ctx + | A.BoxDerefMut -> + eval_box_deref_mut_symbolic config region_params type_params ctx + | A.BoxFree -> failwith "Unreachable" + (* should have been treated above *) + in + + (* Move the return value to its destination *) + let ctx = assign_to_place config ctx ret_value dest in + + (* Return *) + ctx (** Evaluate a non-local (i.e, assumed) function call such as `Box::deref` (auxiliary helper for [eval_statement]) *) @@ -3888,8 +3930,9 @@ let eval_non_local_function_call (config : C.config) (ctx : C.eval_ctx) eval_non_local_function_call_concrete config ctx fid region_params type_params args dest | C.SymbolicMode -> - eval_non_local_function_call_symbolic config ctx fid region_params - type_params args dest + Ok + (eval_non_local_function_call_symbolic config ctx fid region_params + type_params args dest) (** Evaluate a statement *) let rec eval_statement (config : C.config) (ctx : C.eval_ctx) (st : A.statement) diff --git a/src/InterpreterUtils.ml b/src/InterpreterUtils.ml index 20d4c3af..66ca8998 100644 --- a/src/InterpreterUtils.ml +++ b/src/InterpreterUtils.ml @@ -9,6 +9,7 @@ module A = CfimAst module L = Logging open TypesUtils open ValuesUtils +open Utils (** Some utilities *) @@ -147,13 +148,6 @@ type g_borrow_content = (V.borrow_content, V.aborrow_content) concrete_or_abs type abs_or_var_id = AbsId of V.AbstractionId.id | VarId of V.VarId.id -exception Found -(** Utility exception - - When looking for something while exploring a term, it can be easier to - just throw an exception to signal we found what we were looking for. - *) - exception FoundBorrowContent of V.borrow_content (** Utility exception *) diff --git a/src/TypesUtils.ml b/src/TypesUtils.ml index 4b3d8b0f..faf77eac 100644 --- a/src/TypesUtils.ml +++ b/src/TypesUtils.ml @@ -1,4 +1,5 @@ open Types +open Utils (** Retrieve the list of fields for the given variant of a [type_def]. @@ -22,6 +23,32 @@ let ty_is_unit (ty : 'r ty) : bool = (** The unit type *) let mk_unit_ty : ety = Adt (Tuple, [], []) +(** Check if a region is in a set of regions *) +let region_in_set (r : RegionId.id region) (rset : RegionId.set_t) : bool = + match r with Static -> false | Var id -> RegionId.Set.mem id rset + +(** Return the set of regions in an rty *) +let rty_regions (ty : rty) : RegionId.set_t = + let s = ref RegionId.Set.empty in + let add_region (r : RegionId.id region) = + match r with Static -> () | Var rid -> s := RegionId.Set.add rid !s + in + let obj = + object + inherit [_] iter_ty + + method! visit_'r _env r = add_region r + end + in + (* Explore the type *) + obj#visit_ty () ty; + (* Return the set of accumulated regions *) + !s + +let rty_regions_intersect (ty : rty) (regions : RegionId.set_t) : bool = + let ty_regions = rty_regions ty in + not (RegionId.Set.disjoint ty_regions regions) + (** Convert an [ety], containing no region variables, to an [rty]. In practice, it is the identity. @@ -43,3 +70,21 @@ let rec ety_no_regions_to_rty (ty : ety) : rty = failwith "Can't convert a ref with erased regions to a ref with non-erased \ regions" + +(** Check if a [ty] contains regions *) +let rec ty_has_regions (ty : ety) : bool = + let obj = + object + inherit [_] iter_ty as super + + method! visit_Adt env type_id regions tys = + if regions = [] then super#visit_Adt env type_id regions tys + else raise Found + + method! visit_Ref _ _ _ _ = raise Found + end + in + try + obj#visit_ty () ty; + false + with Found -> true -- cgit v1.2.3 From 4feb960fe3b5d58a5420b0c569bcea645a420b9f Mon Sep 17 00:00:00 2001 From: Son Ho Date: Wed, 5 Jan 2022 19:12:56 +0100 Subject: Implement apply_proj_borrows_on_input_value --- src/Interpreter.ml | 27 +++++++++++++++++++-------- 1 file changed, 19 insertions(+), 8 deletions(-) (limited to 'src') diff --git a/src/Interpreter.ml b/src/Interpreter.ml index 0adff0dc..f18124f8 100644 --- a/src/Interpreter.ml +++ b/src/Interpreter.ml @@ -416,11 +416,6 @@ let symbolic_expansion_non_borrow_to_value (sv : V.symbolic_value) in { V.value; V.ty } -let apply_proj_borrows_in_context (check_symbolic_no_ended : bool) - (ctx : C.eval_ctx) (regions : T.RegionId.set_t) (v : V.typed_value) - (ty : T.rty) : C.eval_ctx * V.typed_avalue = - raise Unimplemented - (** Convert a symbolic expansion to a value. If the expansion is a mutable reference expansion, it converts it to a borrow. @@ -849,6 +844,24 @@ let prepare_reborrows (config : C.config) (allow_reborrows : bool) in (fresh_reborrow, apply_registered_reborrows) +let apply_proj_borrows_on_input_value (config : C.config) (ctx : C.eval_ctx) + (regions : T.RegionId.set_t) (v : V.typed_value) (ty : T.rty) : + C.eval_ctx * V.typed_avalue = + let check_symbolic_no_ended = true in + let allow_reborrows = true in + (* Prepare the reborrows *) + let fresh_reborrow, apply_registered_reborrows = + prepare_reborrows config allow_reborrows ctx + in + (* Apply the projector *) + let av = + apply_proj_borrows check_symbolic_no_ended ctx fresh_reborrow regions v ty + in + (* Apply the reborrows *) + let ctx = apply_registered_reborrows ctx in + (* Return *) + (ctx, av) + (** Auxiliary function to end borrows. See [give_back]. When we end a mutable borrow, we need to "give back" the value it contained @@ -4275,12 +4288,10 @@ and eval_local_function_call_symbolic (config : C.config) (ctx : C.eval_ctx) T.RegionId.Set.empty rg.A.regions in (* Project over the input values *) - let check_symbolic_no_ended = true in let ctx, args_projs = List.fold_left_map (fun ctx (arg, arg_rty) -> - apply_proj_borrows_in_context check_symbolic_no_ended ctx regions arg - arg_rty) + apply_proj_borrows_on_input_value config ctx regions arg arg_rty) ctx args_with_rtypes in (* Group the input and output values *) -- cgit v1.2.3 From 8f2038542bcb8ec93b6c6447f38d098cff98fc2c Mon Sep 17 00:00:00 2001 From: Son Ho Date: Wed, 5 Jan 2022 19:21:13 +0100 Subject: Split eval_local_function_call_symbolic to isolate a function which can be reused for non-local function calls --- src/Interpreter.ml | 107 +++++++++++++++++++++++++++++++++-------------------- src/Synthesis.ml | 7 +--- src/Utils.ml | 6 +++ 3 files changed, 74 insertions(+), 46 deletions(-) create mode 100644 src/Utils.ml (limited to 'src') diff --git a/src/Interpreter.ml b/src/Interpreter.ml index f18124f8..3c8e40b6 100644 --- a/src/Interpreter.ml +++ b/src/Interpreter.ml @@ -3877,44 +3877,46 @@ let eval_non_local_function_call_symbolic (config : C.config) (ctx : C.eval_ctx) (fid : A.assumed_fun_id) (region_params : T.erased_region list) (type_params : T.ety list) (args : E.operand list) (dest : E.place) : C.eval_ctx = - (* Synthesis *) - S.synthesize_non_local_function_call fid region_params type_params args dest; - - (* Sanity check: make sure the type parameters don't contain regions - - * this is a current limitation of our synthesis *) - assert (List.for_all (fun ty -> not (ty_has_regions ty)) type_params); - - (* There are two cases (and this is extremely annoying): - - the function is not box_free - - the function is box_free - See [eval_box_free] - *) - match fid with - | A.BoxFree -> - (* Degenerate case: box_free *) - eval_box_free config region_params type_params args dest ctx - | _ -> - (* "Normal" case: not box_free *) - (* Evaluate the operands *) - let ctx, args_vl = eval_operands config ctx args in - - (* Evaluate the function call *) - let ctx, ret_value = - match fid with - | A.BoxNew -> eval_box_new_symbolic config region_params type_params ctx - | A.BoxDeref -> - eval_box_deref_symbolic config region_params type_params ctx - | A.BoxDerefMut -> - eval_box_deref_mut_symbolic config region_params type_params ctx - | A.BoxFree -> failwith "Unreachable" - (* should have been treated above *) - in - - (* Move the return value to its destination *) - let ctx = assign_to_place config ctx ret_value dest in + raise Unimplemented - (* Return *) - ctx +(* (* Synthesis *) + S.synthesize_function_call (A.Assumed fid) region_params type_params args dest; + + (* Sanity check: make sure the type parameters don't contain regions - + * this is a current limitation of our synthesis *) + assert (List.for_all (fun ty -> not (ty_has_regions ty)) type_params); + + (* There are two cases (and this is extremely annoying): + - the function is not box_free + - the function is box_free + See [eval_box_free] + *) + match fid with + | A.BoxFree -> + (* Degenerate case: box_free *) + eval_box_free config region_params type_params args dest ctx + | _ -> + (* "Normal" case: not box_free *) + (* Evaluate the operands *) + let ctx, args_vl = eval_operands config ctx args in + + (* Evaluate the function call *) + let ctx, ret_value = + match fid with + | A.BoxNew -> eval_box_new_symbolic config region_params type_params ctx + | A.BoxDeref -> + eval_box_deref_symbolic config region_params type_params ctx + | A.BoxDerefMut -> + eval_box_deref_mut_symbolic config region_params type_params ctx + | A.BoxFree -> failwith "Unreachable" + (* should have been treated above *) + in + + (* Move the return value to its destination *) + let ctx = assign_to_place config ctx ret_value dest in + + (* Return *) + ctx*) (** Evaluate a non-local (i.e, assumed) function call such as `Box::deref` (auxiliary helper for [eval_statement]) *) @@ -4260,6 +4262,32 @@ and eval_local_function_call_symbolic (config : C.config) (ctx : C.eval_ctx) in (* Substitute the signature *) let inst_sg = Subst.substitute_signature asubst rsubst tsubst sg in + (* TODO: cut from here *) + (* Generate a fresh symbolic value for the return value *) + let ret_sv_ty = inst_sg.A.output in + let ctx, ret_spc = + mk_fresh_symbolic_proj_comp T.RegionId.Set.empty ret_sv_ty ctx + in + let ret_value = mk_typed_value_from_proj_comp ret_spc in + let ret_av = V.ASymbolic (V.AProjLoans ret_spc.V.svalue) in + let ret_av : V.typed_avalue = + { V.value = ret_av; V.ty = ret_spc.V.svalue.V.sv_ty } + in + (* Sanity check *) + assert (List.length args = def.A.arg_count); + (* Evaluate the function call *) + eval_function_call_symbolic_from_inst_sig config ctx (A.Local fid) inst_sg + region_params type_params args dest + +(** Evaluate a function call in symbolic mode by using the function signature. + + This allows us to factorize the evaluation of local and non-local function + calls in symbolic mode: only their signatures matter. + *) +and eval_function_call_symbolic_from_inst_sig (config : C.config) + (ctx : C.eval_ctx) (fid : A.fun_id) (inst_sg : A.inst_fun_sig) + (region_params : T.erased_region list) (type_params : T.ety list) + (args : E.operand list) (dest : E.place) : C.eval_ctx = (* Generate a fresh symbolic value for the return value *) let ret_sv_ty = inst_sg.A.output in let ctx, ret_spc = @@ -4272,8 +4300,7 @@ and eval_local_function_call_symbolic (config : C.config) (ctx : C.eval_ctx) in (* Evaluate the input operands *) let ctx, args = eval_operands config ctx args in - assert (List.length args = def.A.arg_count); - let args_with_rtypes = List.combine args rtype_params in + let args_with_rtypes = List.combine args inst_sg.A.inputs in (* Generate the abstractions from the region groups and add them to the context *) let gen_abs (ctx : C.eval_ctx) (rg : A.abs_region_group) : C.eval_ctx = let abs_id = rg.A.id in @@ -4307,7 +4334,7 @@ and eval_local_function_call_symbolic (config : C.config) (ctx : C.eval_ctx) (* Move the return value to its destination *) let ctx = assign_to_place config ctx ret_value dest in (* Synthesis *) - S.synthesize_local_function_call fid region_params type_params args dest + S.synthesize_function_call fid region_params type_params args dest ret_spc.V.svalue; (* Return *) ctx diff --git a/src/Synthesis.ml b/src/Synthesis.ml index 60c387d2..1f683209 100644 --- a/src/Synthesis.ml +++ b/src/Synthesis.ml @@ -63,12 +63,7 @@ let synthesize_eval_rvalue_aggregate (aggregate_kind : E.aggregate_kind) (ops : E.operand list) : unit = () -let synthesize_non_local_function_call (fid : A.assumed_fun_id) - (region_params : T.erased_region list) (type_params : T.ety list) - (args : E.operand list) (dest : E.place) : unit = - () - -let synthesize_local_function_call (fid : A.FunDefId.id) +let synthesize_function_call (fid : A.fun_id) (region_params : T.erased_region list) (type_params : T.ety list) (args : V.typed_value list) (dest : E.place) (res : V.symbolic_value) : unit = diff --git a/src/Utils.ml b/src/Utils.ml new file mode 100644 index 00000000..a285e869 --- /dev/null +++ b/src/Utils.ml @@ -0,0 +1,6 @@ +exception Found +(** Utility exception + + When looking for something while exploring a term, it can be easier to + just throw an exception to signal we found what we were looking for. + *) -- cgit v1.2.3 From 6b9653a3f1a361c72eb841a5a9c04a374b99c8e5 Mon Sep 17 00:00:00 2001 From: Son Ho Date: Wed, 5 Jan 2022 19:22:08 +0100 Subject: Cleanup a bit --- src/Interpreter.ml | 11 ----------- 1 file changed, 11 deletions(-) (limited to 'src') diff --git a/src/Interpreter.ml b/src/Interpreter.ml index 3c8e40b6..770c1c71 100644 --- a/src/Interpreter.ml +++ b/src/Interpreter.ml @@ -4262,17 +4262,6 @@ and eval_local_function_call_symbolic (config : C.config) (ctx : C.eval_ctx) in (* Substitute the signature *) let inst_sg = Subst.substitute_signature asubst rsubst tsubst sg in - (* TODO: cut from here *) - (* Generate a fresh symbolic value for the return value *) - let ret_sv_ty = inst_sg.A.output in - let ctx, ret_spc = - mk_fresh_symbolic_proj_comp T.RegionId.Set.empty ret_sv_ty ctx - in - let ret_value = mk_typed_value_from_proj_comp ret_spc in - let ret_av = V.ASymbolic (V.AProjLoans ret_spc.V.svalue) in - let ret_av : V.typed_avalue = - { V.value = ret_av; V.ty = ret_spc.V.svalue.V.sv_ty } - in (* Sanity check *) assert (List.length args = def.A.arg_count); (* Evaluate the function call *) -- cgit v1.2.3 From de4a2300b734e9ea9c29a160a968110507d7747f Mon Sep 17 00:00:00 2001 From: Son Ho Date: Wed, 5 Jan 2022 19:52:07 +0100 Subject: Make progress on eval_non_local_function_call_symbolic --- src/Interpreter.ml | 138 +++++++++++++++++++++++++++++------------------- src/InterpreterUtils.ml | 8 ++- 2 files changed, 92 insertions(+), 54 deletions(-) (limited to 'src') diff --git a/src/Interpreter.ml b/src/Interpreter.ml index 770c1c71..50b53a67 100644 --- a/src/Interpreter.ml +++ b/src/Interpreter.ml @@ -3778,32 +3778,66 @@ let eval_box_free (config : C.config) (region_params : T.erased_region list) | _ -> failwith "Inconsistent state" (** Auxiliary function - see [eval_non_local_function_call] *) -let eval_box_new_symbolic (config : C.config) - (region_params : T.erased_region list) (type_params : T.ety list) - (ctx : C.eval_ctx) : C.eval_ctx * V.typed_value = - raise Unimplemented +let eval_box_new_inst_sig (config : C.config) + (region_params : T.erased_region list) (type_params : T.ety list) : + A.inst_fun_sig = + (* The signature is: + `T -> Box` + where T is the type pram + *) + match (region_params, type_params) with + | [], [ ty_param ] -> + let input = ety_no_regions_to_rty ty_param in + let output = mk_box_ty ty_param in + let output = ety_no_regions_to_rty output in + { A.regions_hierarchy = []; inputs = [ input ]; output } + | _ -> failwith "Inconsistent state" (** Auxiliary function which factorizes code to evaluate `std::Deref::deref` and `std::DerefMut::deref_mut` - see [eval_non_local_function_call] *) -let eval_box_deref_mut_or_shared_symbolic (config : C.config) +let eval_box_deref_mut_or_shared_inst_sig (config : C.config) (region_params : T.erased_region list) (type_params : T.ety list) - (is_mut : bool) (ctx : C.eval_ctx) : C.eval_ctx * V.typed_value = - raise Unimplemented + (is_mut : bool) (ctx : C.eval_ctx) : C.eval_ctx * A.inst_fun_sig = + (* The signature is: + `&'a (mut) Box -> &'a (mut) T` + where T is the type param + *) + let ctx, rid = C.fresh_region_id ctx in + let r = T.Var rid in + let ctx, abs_id = C.fresh_abstraction_id ctx in + match (region_params, type_params) with + | [], [ ty_param ] -> + let ty_param = ety_no_regions_to_rty ty_param in + let ref_kind = if is_mut then T.Mut else T.Shared in + + let input = mk_box_ty ty_param in + let input = mk_ref_ty r input ref_kind in + + let output = mk_ref_ty r ty_param ref_kind in + + let regions = { A.id = abs_id; regions = [ rid ]; parents = [] } in + + let inst_sg = + { A.regions_hierarchy = [ regions ]; inputs = [ input ]; output } + in + + (ctx, inst_sg) + | _ -> failwith "Inconsistent state" (** Auxiliary function - see [eval_non_local_function_call] *) -let eval_box_deref_symbolic (config : C.config) +let eval_box_deref_inst_sig (config : C.config) (region_params : T.erased_region list) (type_params : T.ety list) - (ctx : C.eval_ctx) : C.eval_ctx * V.typed_value = + (ctx : C.eval_ctx) : C.eval_ctx * A.inst_fun_sig = let is_mut = false in - eval_box_deref_mut_or_shared_symbolic config region_params type_params is_mut + eval_box_deref_mut_or_shared_inst_sig config region_params type_params is_mut ctx (** Auxiliary function - see [eval_non_local_function_call] *) -let eval_box_deref_mut_symbolic (config : C.config) +let eval_box_deref_mut_inst_sig (config : C.config) (region_params : T.erased_region list) (type_params : T.ety list) - (ctx : C.eval_ctx) : C.eval_ctx * V.typed_value = + (ctx : C.eval_ctx) : C.eval_ctx * A.inst_fun_sig = let is_mut = true in - eval_box_deref_mut_or_shared_symbolic config region_params type_params is_mut + eval_box_deref_mut_or_shared_inst_sig config region_params type_params is_mut ctx (** Evaluate a non-local function call in concrete mode *) @@ -3877,46 +3911,38 @@ let eval_non_local_function_call_symbolic (config : C.config) (ctx : C.eval_ctx) (fid : A.assumed_fun_id) (region_params : T.erased_region list) (type_params : T.ety list) (args : E.operand list) (dest : E.place) : C.eval_ctx = - raise Unimplemented - -(* (* Synthesis *) - S.synthesize_function_call (A.Assumed fid) region_params type_params args dest; - - (* Sanity check: make sure the type parameters don't contain regions - - * this is a current limitation of our synthesis *) - assert (List.for_all (fun ty -> not (ty_has_regions ty)) type_params); - - (* There are two cases (and this is extremely annoying): - - the function is not box_free - - the function is box_free - See [eval_box_free] - *) - match fid with - | A.BoxFree -> - (* Degenerate case: box_free *) - eval_box_free config region_params type_params args dest ctx - | _ -> - (* "Normal" case: not box_free *) - (* Evaluate the operands *) - let ctx, args_vl = eval_operands config ctx args in - - (* Evaluate the function call *) - let ctx, ret_value = - match fid with - | A.BoxNew -> eval_box_new_symbolic config region_params type_params ctx - | A.BoxDeref -> - eval_box_deref_symbolic config region_params type_params ctx - | A.BoxDerefMut -> - eval_box_deref_mut_symbolic config region_params type_params ctx - | A.BoxFree -> failwith "Unreachable" - (* should have been treated above *) - in - - (* Move the return value to its destination *) - let ctx = assign_to_place config ctx ret_value dest in - - (* Return *) - ctx*) + (* Sanity check: make sure the type parameters don't contain regions - + * this is a current limitation of our synthesis *) + assert (List.for_all (fun ty -> not (ty_has_regions ty)) type_params); + + (* There are two cases (and this is extremely annoying): + - the function is not box_free + - the function is box_free + See [eval_box_free] + *) + match fid with + | A.BoxFree -> + (* Degenerate case: box_free - note that this is not really a function + * call *) + eval_box_free config region_params type_params args dest ctx + | _ -> + (* "Normal" case: not box_free *) + (* In symbolic mode, the behaviour of a function call is completely defined + * by the signature of the function: we thus simply generate correctly + * instantiated signatures, and delegate the work to an auxiliary function *) + let ctx, inst_sig = + match fid with + | A.BoxNew -> + (ctx, eval_box_new_inst_sig config region_params type_params) + | A.BoxDeref -> + eval_box_deref_inst_sig config region_params type_params ctx + | A.BoxDerefMut -> + eval_box_deref_mut_inst_sig config region_params type_params ctx + | A.BoxFree -> failwith "Unreachable" + (* should have been treated above *) + in + + raise Unimplemented (** Evaluate a non-local (i.e, assumed) function call such as `Box::deref` (auxiliary helper for [eval_statement]) *) @@ -4290,6 +4316,12 @@ and eval_function_call_symbolic_from_inst_sig (config : C.config) (* Evaluate the input operands *) let ctx, args = eval_operands config ctx args in let args_with_rtypes = List.combine args inst_sg.A.inputs in + (* Check the type of the input arguments *) + assert ( + List.for_all + (fun ((arg, rty) : V.typed_value * T.rty) -> + arg.V.ty = Subst.erase_regions rty) + args_with_rtypes); (* Generate the abstractions from the region groups and add them to the context *) let gen_abs (ctx : C.eval_ctx) (rg : A.abs_region_group) : C.eval_ctx = let abs_id = rg.A.id in diff --git a/src/InterpreterUtils.ml b/src/InterpreterUtils.ml index 66ca8998..edc8594c 100644 --- a/src/InterpreterUtils.ml +++ b/src/InterpreterUtils.ml @@ -52,9 +52,15 @@ let ty_get_ref (ty : T.ety) : T.erased_region * T.ety * T.ref_kind = | T.Ref (r, ty, ref_kind) -> (r, ty, ref_kind) | _ -> failwith "Not a ref type" +let mk_ref_ty (r : 'r) (ty : 'r T.ty) (ref_kind : T.ref_kind) : 'r T.ty = + T.Ref (r, ty, ref_kind) + +(** Make a box type *) +let mk_box_ty (ty : 'r T.ty) : 'r T.ty = T.Adt (T.Assumed T.Box, [], [ ty ]) + (** Box a value *) let mk_box_value (v : V.typed_value) : V.typed_value = - let box_ty = T.Adt (T.Assumed T.Box, [], [ v.V.ty ]) in + let box_ty = mk_box_ty v.V.ty in let box_v = V.Adt { variant_id = None; field_values = [ v ] } in mk_typed_value box_ty box_v -- cgit v1.2.3 From e2a6d69a125f7a4510eecd79c01d3420bb561a9d Mon Sep 17 00:00:00 2001 From: Son Ho Date: Wed, 5 Jan 2022 19:55:47 +0100 Subject: Finish implementing evaluation of non-local function calls in symbolic mode --- src/Interpreter.ml | 140 +++++++++++++++++++++++++++-------------------------- 1 file changed, 71 insertions(+), 69 deletions(-) (limited to 'src') diff --git a/src/Interpreter.ml b/src/Interpreter.ml index 50b53a67..da72d3c3 100644 --- a/src/Interpreter.ml +++ b/src/Interpreter.ml @@ -3906,75 +3906,6 @@ let eval_non_local_function_call_concrete (config : C.config) (ctx : C.eval_ctx) (* Return *) Ok ctx) -(** Evaluate a non-local function call in concrete mode *) -let eval_non_local_function_call_symbolic (config : C.config) (ctx : C.eval_ctx) - (fid : A.assumed_fun_id) (region_params : T.erased_region list) - (type_params : T.ety list) (args : E.operand list) (dest : E.place) : - C.eval_ctx = - (* Sanity check: make sure the type parameters don't contain regions - - * this is a current limitation of our synthesis *) - assert (List.for_all (fun ty -> not (ty_has_regions ty)) type_params); - - (* There are two cases (and this is extremely annoying): - - the function is not box_free - - the function is box_free - See [eval_box_free] - *) - match fid with - | A.BoxFree -> - (* Degenerate case: box_free - note that this is not really a function - * call *) - eval_box_free config region_params type_params args dest ctx - | _ -> - (* "Normal" case: not box_free *) - (* In symbolic mode, the behaviour of a function call is completely defined - * by the signature of the function: we thus simply generate correctly - * instantiated signatures, and delegate the work to an auxiliary function *) - let ctx, inst_sig = - match fid with - | A.BoxNew -> - (ctx, eval_box_new_inst_sig config region_params type_params) - | A.BoxDeref -> - eval_box_deref_inst_sig config region_params type_params ctx - | A.BoxDerefMut -> - eval_box_deref_mut_inst_sig config region_params type_params ctx - | A.BoxFree -> failwith "Unreachable" - (* should have been treated above *) - in - - raise Unimplemented - -(** Evaluate a non-local (i.e, assumed) function call such as `Box::deref` - (auxiliary helper for [eval_statement]) *) -let eval_non_local_function_call (config : C.config) (ctx : C.eval_ctx) - (fid : A.assumed_fun_id) (region_params : T.erased_region list) - (type_params : T.ety list) (args : E.operand list) (dest : E.place) : - C.eval_ctx eval_result = - (* Debug *) - L.log#ldebug - (lazy - (let type_params = - "[" - ^ String.concat ", " (List.map (ety_to_string ctx) type_params) - ^ "]" - in - let args = - "[" ^ String.concat ", " (List.map (operand_to_string ctx) args) ^ "]" - in - let dest = place_to_string ctx dest in - "eval_non_local_function_call:\n- fid:" ^ A.show_assumed_fun_id fid - ^ "\n- type_params: " ^ type_params ^ "\n- args: " ^ args ^ "\n- dest: " - ^ dest)); - - match config.mode with - | C.ConcreteMode -> - eval_non_local_function_call_concrete config ctx fid region_params - type_params args dest - | C.SymbolicMode -> - Ok - (eval_non_local_function_call_symbolic config ctx fid region_params - type_params args dest) - (** Evaluate a statement *) let rec eval_statement (config : C.config) (ctx : C.eval_ctx) (st : A.statement) : (C.eval_ctx * statement_eval_res) eval_result list = @@ -4360,6 +4291,77 @@ and eval_function_call_symbolic_from_inst_sig (config : C.config) (* Return *) ctx +(** Evaluate a non-local function call in symbolic mode *) +and eval_non_local_function_call_symbolic (config : C.config) (ctx : C.eval_ctx) + (fid : A.assumed_fun_id) (region_params : T.erased_region list) + (type_params : T.ety list) (args : E.operand list) (dest : E.place) : + C.eval_ctx = + (* Sanity check: make sure the type parameters don't contain regions - + * this is a current limitation of our synthesis *) + assert (List.for_all (fun ty -> not (ty_has_regions ty)) type_params); + + (* There are two cases (and this is extremely annoying): + - the function is not box_free + - the function is box_free + See [eval_box_free] + *) + match fid with + | A.BoxFree -> + (* Degenerate case: box_free - note that this is not really a function + * call: no need to call a "synthesize_..." function *) + eval_box_free config region_params type_params args dest ctx + | _ -> + (* "Normal" case: not box_free *) + (* In symbolic mode, the behaviour of a function call is completely defined + * by the signature of the function: we thus simply generate correctly + * instantiated signatures, and delegate the work to an auxiliary function *) + let ctx, inst_sig = + match fid with + | A.BoxNew -> + (ctx, eval_box_new_inst_sig config region_params type_params) + | A.BoxDeref -> + eval_box_deref_inst_sig config region_params type_params ctx + | A.BoxDerefMut -> + eval_box_deref_mut_inst_sig config region_params type_params ctx + | A.BoxFree -> failwith "Unreachable" + (* should have been treated above *) + in + + (* Evaluate the function call *) + eval_function_call_symbolic_from_inst_sig config ctx (A.Assumed fid) + inst_sig region_params type_params args dest + +(** Evaluate a non-local (i.e, assumed) function call such as `Box::deref` + (auxiliary helper for [eval_statement]) *) +and eval_non_local_function_call (config : C.config) (ctx : C.eval_ctx) + (fid : A.assumed_fun_id) (region_params : T.erased_region list) + (type_params : T.ety list) (args : E.operand list) (dest : E.place) : + C.eval_ctx eval_result = + (* Debug *) + L.log#ldebug + (lazy + (let type_params = + "[" + ^ String.concat ", " (List.map (ety_to_string ctx) type_params) + ^ "]" + in + let args = + "[" ^ String.concat ", " (List.map (operand_to_string ctx) args) ^ "]" + in + let dest = place_to_string ctx dest in + "eval_non_local_function_call:\n- fid:" ^ A.show_assumed_fun_id fid + ^ "\n- type_params: " ^ type_params ^ "\n- args: " ^ args ^ "\n- dest: " + ^ dest)); + + match config.mode with + | C.ConcreteMode -> + eval_non_local_function_call_concrete config ctx fid region_params + type_params args dest + | C.SymbolicMode -> + Ok + (eval_non_local_function_call_symbolic config ctx fid region_params + type_params args dest) + (** Evaluate a local (i.e, not assumed) function call (auxiliary helper for [eval_statement]) *) and eval_local_function_call (config : C.config) (ctx : C.eval_ctx) -- cgit v1.2.3 From 067be88c6c3fc61a55eeeaf8ccf59a9ce423e68d Mon Sep 17 00:00:00 2001 From: Son Ho Date: Wed, 5 Jan 2022 19:57:11 +0100 Subject: Cleanup a bit --- src/Interpreter.ml | 39 +++++++++++++++++---------------------- 1 file changed, 17 insertions(+), 22 deletions(-) (limited to 'src') diff --git a/src/Interpreter.ml b/src/Interpreter.ml index da72d3c3..a3f22660 100644 --- a/src/Interpreter.ml +++ b/src/Interpreter.ml @@ -3778,9 +3778,8 @@ let eval_box_free (config : C.config) (region_params : T.erased_region list) | _ -> failwith "Inconsistent state" (** Auxiliary function - see [eval_non_local_function_call] *) -let eval_box_new_inst_sig (config : C.config) - (region_params : T.erased_region list) (type_params : T.ety list) : - A.inst_fun_sig = +let eval_box_new_inst_sig (region_params : T.erased_region list) + (type_params : T.ety list) : A.inst_fun_sig = (* The signature is: `T -> Box` where T is the type pram @@ -3795,9 +3794,9 @@ let eval_box_new_inst_sig (config : C.config) (** Auxiliary function which factorizes code to evaluate `std::Deref::deref` and `std::DerefMut::deref_mut` - see [eval_non_local_function_call] *) -let eval_box_deref_mut_or_shared_inst_sig (config : C.config) - (region_params : T.erased_region list) (type_params : T.ety list) - (is_mut : bool) (ctx : C.eval_ctx) : C.eval_ctx * A.inst_fun_sig = +let eval_box_deref_mut_or_shared_inst_sig (region_params : T.erased_region list) + (type_params : T.ety list) (is_mut : bool) (ctx : C.eval_ctx) : + C.eval_ctx * A.inst_fun_sig = (* The signature is: `&'a (mut) Box -> &'a (mut) T` where T is the type param @@ -3825,20 +3824,18 @@ let eval_box_deref_mut_or_shared_inst_sig (config : C.config) | _ -> failwith "Inconsistent state" (** Auxiliary function - see [eval_non_local_function_call] *) -let eval_box_deref_inst_sig (config : C.config) - (region_params : T.erased_region list) (type_params : T.ety list) - (ctx : C.eval_ctx) : C.eval_ctx * A.inst_fun_sig = +let eval_box_deref_inst_sig (region_params : T.erased_region list) + (type_params : T.ety list) (ctx : C.eval_ctx) : C.eval_ctx * A.inst_fun_sig + = let is_mut = false in - eval_box_deref_mut_or_shared_inst_sig config region_params type_params is_mut - ctx + eval_box_deref_mut_or_shared_inst_sig region_params type_params is_mut ctx (** Auxiliary function - see [eval_non_local_function_call] *) -let eval_box_deref_mut_inst_sig (config : C.config) - (region_params : T.erased_region list) (type_params : T.ety list) - (ctx : C.eval_ctx) : C.eval_ctx * A.inst_fun_sig = +let eval_box_deref_mut_inst_sig (region_params : T.erased_region list) + (type_params : T.ety list) (ctx : C.eval_ctx) : C.eval_ctx * A.inst_fun_sig + = let is_mut = true in - eval_box_deref_mut_or_shared_inst_sig config region_params type_params is_mut - ctx + eval_box_deref_mut_or_shared_inst_sig region_params type_params is_mut ctx (** Evaluate a non-local function call in concrete mode *) let eval_non_local_function_call_concrete (config : C.config) (ctx : C.eval_ctx) @@ -4117,7 +4114,7 @@ and eval_function_call (config : C.config) (ctx : C.eval_ctx) (call : A.call) : (** Evaluate a local (i.e., non-assumed) function call in concrete mode *) and eval_local_function_call_concrete (config : C.config) (ctx : C.eval_ctx) - (fid : A.FunDefId.id) (region_params : T.erased_region list) + (fid : A.FunDefId.id) (_region_params : T.erased_region list) (type_params : T.ety list) (args : E.operand list) (dest : E.place) : C.eval_ctx eval_result list = (* Retrieve the (correctly instantiated) body *) @@ -4317,12 +4314,10 @@ and eval_non_local_function_call_symbolic (config : C.config) (ctx : C.eval_ctx) * instantiated signatures, and delegate the work to an auxiliary function *) let ctx, inst_sig = match fid with - | A.BoxNew -> - (ctx, eval_box_new_inst_sig config region_params type_params) - | A.BoxDeref -> - eval_box_deref_inst_sig config region_params type_params ctx + | A.BoxNew -> (ctx, eval_box_new_inst_sig region_params type_params) + | A.BoxDeref -> eval_box_deref_inst_sig region_params type_params ctx | A.BoxDerefMut -> - eval_box_deref_mut_inst_sig config region_params type_params ctx + eval_box_deref_mut_inst_sig region_params type_params ctx | A.BoxFree -> failwith "Unreachable" (* should have been treated above *) in -- cgit v1.2.3 From 6f25cbb0dd202b53fe850560ddf566c75183af7d Mon Sep 17 00:00:00 2001 From: Son Ho Date: Thu, 6 Jan 2022 10:07:15 +0100 Subject: Generate iterators for statement --- src/CfimAst.ml | 51 ++++++++++++++++++++++++++++++++++++++++++++++++++- src/Values.ml | 8 ++++---- 2 files changed, 54 insertions(+), 5 deletions(-) (limited to 'src') diff --git a/src/CfimAst.ml b/src/CfimAst.ml index 23c8f1aa..a4a128c3 100644 --- a/src/CfimAst.ml +++ b/src/CfimAst.ml @@ -82,6 +82,38 @@ type call = { } [@@deriving show] +(** Ancestor for [typed_value] iter visitor *) +class ['self] iter_statement_base = + object (_self : 'self) + inherit [_] VisitorsRuntime.iter + + method visit_place : 'env -> place -> unit = fun _ _ -> () + + method visit_rvalue : 'env -> rvalue -> unit = fun _ _ -> () + + method visit_id : 'env -> VariantId.id -> unit = fun _ _ -> () + + method visit_assertion : 'env -> assertion -> unit = fun _ _ -> () + + method visit_call : 'env -> call -> unit = fun _ _ -> () + end + +(** Ancestor for [typed_value] map visitor *) +class ['self] map_statement_base = + object (_self : 'self) + inherit [_] VisitorsRuntime.iter + + method visit_place : 'env -> place -> place = fun _ x -> x + + method visit_rvalue : 'env -> rvalue -> rvalue = fun _ x -> x + + method visit_id : 'env -> VariantId.id -> VariantId.id = fun _ x -> x + + method visit_assertion : 'env -> assertion -> assertion = fun _ x -> x + + method visit_call : 'env -> call -> call = fun _ x -> x + end + type statement = | Assign of place * rvalue | FakeRead of place @@ -114,7 +146,24 @@ and switch_targets = - the "otherwise" statement. Also note that we precise the type of the integer (uint32, int64, etc.) which we switch on. *) -[@@deriving show] +[@@deriving + show, + visitors + { + name = "iter_statement"; + variety = "iter"; + ancestors = [ "iter_statement_base" ]; + nude = true (* Don't inherit [VisitorsRuntime.iter] *); + concrete = true; + }, + visitors + { + name = "map_statement"; + variety = "map"; + ancestors = [ "map_statement_base" ]; + nude = true (* Don't inherit [VisitorsRuntime.iter] *); + concrete = true; + }] type fun_def = { def_id : FunDefId.id; diff --git a/src/Values.ml b/src/Values.ml index ae9eb127..ac4145eb 100644 --- a/src/Values.ml +++ b/src/Values.ml @@ -77,7 +77,7 @@ type symbolic_proj_comp = { regions *but* the ones which are listed in the projector. *) -(** Ancestor for iter visitor for [typed_value] *) +(** Ancestor for [typed_value] iter visitor *) class ['self] iter_typed_value_base = object (_self : 'self) inherit [_] VisitorsRuntime.iter @@ -92,7 +92,7 @@ class ['self] iter_typed_value_base = method visit_ety : 'env -> ety -> unit = fun _ _ -> () end -(** Ancestor for map visitor for [typed_value] *) +(** Ancestor for [typed_value] map visitor for *) class ['self] map_typed_value_base = object (_self : 'self) inherit [_] VisitorsRuntime.map @@ -215,7 +215,7 @@ type aproj = type region = RegionVarId.id Types.region [@@deriving show] -(** Ancestor for iter visitor for [typed_avalue] *) +(** Ancestor for [typed_avalue] iter visitor *) class ['self] iter_typed_avalue_base = object (_self : 'self) inherit [_] iter_typed_value @@ -231,7 +231,7 @@ class ['self] iter_typed_avalue_base = fun _ _ -> () end -(** Ancestor for MAP visitor for [typed_avalue] *) +(** Ancestor for [typed_avalue] map visitor *) class ['self] map_typed_avalue_base = object (_self : 'self) inherit [_] map_typed_value -- cgit v1.2.3 From 5ba37ac224892a4c52cf8ab97c2352c217c27270 Mon Sep 17 00:00:00 2001 From: Son Ho Date: Thu, 6 Jan 2022 10:08:05 +0100 Subject: Address some warnings --- src/Synthesis.ml | 39 ++++++++++++++++++++------------------- 1 file changed, 20 insertions(+), 19 deletions(-) (limited to 'src') diff --git a/src/Synthesis.ml b/src/Synthesis.ml index 1f683209..d240714e 100644 --- a/src/Synthesis.ml +++ b/src/Synthesis.ml @@ -29,42 +29,43 @@ open InterpreterUtils (** Synthesize code for a symbolic expansion which doesn't lead to branching (i.e., applied on a value which is not an enumeration with several variants). *) -let synthesize_symbolic_expansion_no_branching (sv : V.symbolic_value) - (see : symbolic_expansion) : unit = +let synthesize_symbolic_expansion_no_branching (_sv : V.symbolic_value) + (_see : symbolic_expansion) : unit = () (** Synthesize code for a symbolic enum expansion (which leads to branching) *) -let synthesize_symbolic_expansion_enum_branching (sv : V.symbolic_value) - (seel : symbolic_expansion list) : unit = +let synthesize_symbolic_expansion_enum_branching (_sv : V.symbolic_value) + (_seel : symbolic_expansion list) : unit = () -let synthesize_symbolic_expansion_if_branching (sv : V.symbolic_value) : unit = +let synthesize_symbolic_expansion_if_branching (_sv : V.symbolic_value) : unit = () -let synthesize_symbolic_expansion_switch_int_branching (sv : V.symbolic_value) : - unit = +let synthesize_symbolic_expansion_switch_int_branching (_sv : V.symbolic_value) + : unit = () -let synthesize_unary_op (unop : E.unop) (op : V.typed_value) - (dest : V.symbolic_value) : unit = +let synthesize_unary_op (_unop : E.unop) (_op : V.typed_value) + (_dest : V.symbolic_value) : unit = () -let synthesize_binary_op (binop : E.binop) (op1 : V.typed_value) - (op2 : V.typed_value) (dest : V.symbolic_value) : unit = +let synthesize_binary_op (_binop : E.binop) (_op1 : V.typed_value) + (_op2 : V.typed_value) (_dest : V.symbolic_value) : unit = () (** Actually not sure if we need this, or a synthesize_symbolic_expansion_enum *) -let synthesize_eval_rvalue_discriminant (p : E.place) : unit = () +let synthesize_eval_rvalue_discriminant (_p : E.place) : unit = () -let synthesize_eval_rvalue_ref (p : E.place) (bkind : E.borrow_kind) : unit = () +let synthesize_eval_rvalue_ref (_p : E.place) (_bkind : E.borrow_kind) : unit = + () -let synthesize_eval_rvalue_aggregate (aggregate_kind : E.aggregate_kind) - (ops : E.operand list) : unit = +let synthesize_eval_rvalue_aggregate (_aggregate_kind : E.aggregate_kind) + (_ops : E.operand list) : unit = () -let synthesize_function_call (fid : A.fun_id) - (region_params : T.erased_region list) (type_params : T.ety list) - (args : V.typed_value list) (dest : E.place) (res : V.symbolic_value) : unit - = +let synthesize_function_call (_fid : A.fun_id) + (_region_params : T.erased_region list) (_type_params : T.ety list) + (_args : V.typed_value list) (_dest : E.place) (_res : V.symbolic_value) : + unit = () -- cgit v1.2.3 From 6179fed42a11365c753aee55470bb69dc780e1ba Mon Sep 17 00:00:00 2001 From: Son Ho Date: Thu, 6 Jan 2022 10:10:33 +0100 Subject: Implement statement_has_loops and make minor modifications --- src/CfimAstUtils.ml | 16 ++++++++++++++++ src/Substitute.ml | 1 - src/TypesUtils.ml | 2 +- 3 files changed, 17 insertions(+), 2 deletions(-) create mode 100644 src/CfimAstUtils.ml (limited to 'src') diff --git a/src/CfimAstUtils.ml b/src/CfimAstUtils.ml new file mode 100644 index 00000000..f811475c --- /dev/null +++ b/src/CfimAstUtils.ml @@ -0,0 +1,16 @@ +open CfimAst +open Utils + +(** Check if a [statement] contains loops *) +let rec statement_has_loops (st : statement) : bool = + let obj = + object + inherit [_] iter_statement + + method! visit_Loop _ _ = raise Found + end + in + try + obj#visit_statement () st; + false + with Found -> true diff --git a/src/Substitute.ml b/src/Substitute.ml index d3c3c430..1b6003bb 100644 --- a/src/Substitute.ml +++ b/src/Substitute.ml @@ -52,7 +52,6 @@ let fresh_regions_with_substs (region_vars : T.region_var list) let ctx, fresh_region_ids = List.fold_left_map (fun ctx _ -> C.fresh_region_id ctx) ctx region_vars in - let fresh_regions = List.map (fun rid -> T.Var rid) fresh_region_ids in (* Generate the map from region var ids to regions *) let ls = List.combine region_vars fresh_region_ids in let rid_map = diff --git a/src/TypesUtils.ml b/src/TypesUtils.ml index faf77eac..c1f52120 100644 --- a/src/TypesUtils.ml +++ b/src/TypesUtils.ml @@ -72,7 +72,7 @@ let rec ety_no_regions_to_rty (ty : ety) : rty = regions" (** Check if a [ty] contains regions *) -let rec ty_has_regions (ty : ety) : bool = +let ty_has_regions (ty : ety) : bool = let obj = object inherit [_] iter_ty as super -- cgit v1.2.3 From c794ffc73738393850fc257a7916d0fd2c87d87f Mon Sep 17 00:00:00 2001 From: Son Ho Date: Thu, 6 Jan 2022 10:21:39 +0100 Subject: Move some functions from Interpreter to InterpreterProjectors --- src/Interpreter.ml | 637 +------------------------------------------ src/InterpreterProjectors.ml | 505 ++++++++++++++++++++++++++++++++++ src/InterpreterUtils.ml | 160 +++++++++++ 3 files changed, 667 insertions(+), 635 deletions(-) create mode 100644 src/InterpreterProjectors.ml (limited to 'src') diff --git a/src/Interpreter.ml b/src/Interpreter.ml index a3f22660..afe513be 100644 --- a/src/Interpreter.ml +++ b/src/Interpreter.ml @@ -10,9 +10,10 @@ module L = Logging open TypesUtils open ValuesUtils module Inv = Invariants -open InterpreterUtils module S = Synthesis open Utils +open InterpreterUtils +open InterpreterProjectors (* TODO: check that the value types are correct when evaluating *) (* TODO: for debugging purposes, we might want to put use eval_ctx everywhere @@ -34,450 +35,6 @@ type eval_error = Panic type 'a eval_result = ('a, eval_error) result -(** The following type identifies the relative position of expressions (in - particular borrows) in other expressions. - - For instance, it is used to control [end_borrow]: we usually only allow - to end "outer" borrows, unless we perform a drop. -*) -type inner_outer = Inner | Outer - -type borrow_ids = Borrows of V.BorrowId.Set.t | Borrow of V.BorrowId.id - -exception FoundBorrowIds of borrow_ids - -let update_if_none opt x = match opt with None -> Some x | _ -> opt - -(** Auxiliary function: see its usage in [end_borrow_get_borrow_in_value] *) -let update_outer_borrows (io : inner_outer) - (outer : V.AbstractionId.id option * borrow_ids option) (x : borrow_ids) : - V.AbstractionId.id option * borrow_ids option = - match io with - | Inner -> - (* If we can end inner borrows, we don't keep track of the outer borrows *) - outer - | Outer -> - let abs, opt = outer in - (abs, update_if_none opt x) - -(** Return the first loan we find in a value *) -let get_first_loan_in_value (v : V.typed_value) : V.loan_content option = - let obj = - object - inherit [_] V.iter_typed_value - - method! visit_loan_content _ lc = raise (FoundLoanContent lc) - end - in - (* We use exceptions *) - try - obj#visit_typed_value () v; - None - with FoundLoanContent lc -> Some lc - -(** Check if two different projections intersect. This is necessary when - giving a symbolic value to an abstraction: we need to check that - the regions which are already ended inside the abstraction don't - intersect the regions over which we project in the new abstraction. - Note that the two abstractions have different views (in terms of regions) - of the symbolic value (hence the two region types). -*) -let rec projections_intersect (ty1 : T.rty) (rset1 : T.RegionId.set_t) - (ty2 : T.rty) (rset2 : T.RegionId.set_t) : bool = - match (ty1, ty2) with - | T.Bool, T.Bool | T.Char, T.Char | T.Str, T.Str -> false - | T.Integer int_ty1, T.Integer int_ty2 -> - assert (int_ty1 = int_ty2); - false - | T.Adt (id1, regions1, tys1), T.Adt (id2, regions2, tys2) -> - assert (id1 = id2); - (* The intersection check for the ADTs is very crude: - * we check if some arguments intersect. As all the type and region - * parameters should be used somewhere in the ADT (otherwise rustc - * generates an error), it means that it should be equivalent to checking - * whether two fields intersect (and anyway comparing the field types is - * difficult in case of enumerations...). - * If we didn't have the above property enforced by the rust compiler, - * this check would still be a reasonable conservative approximation. *) - let regions = List.combine regions1 regions2 in - let tys = List.combine tys1 tys2 in - List.exists - (fun (r1, r2) -> region_in_set r1 rset1 && region_in_set r2 rset2) - regions - || List.exists - (fun (ty1, ty2) -> projections_intersect ty1 rset1 ty2 rset2) - tys - | T.Array ty1, T.Array ty2 | T.Slice ty1, T.Slice ty2 -> - projections_intersect ty1 rset1 ty2 rset2 - | T.Ref (r1, ty1, kind1), T.Ref (r2, ty2, kind2) -> - (* Sanity check *) - assert (kind1 = kind2); - (* The projections intersect if the borrows intersect or their contents - * intersect *) - (region_in_set r1 rset1 && region_in_set r2 rset2) - || projections_intersect ty1 rset1 ty2 rset2 - | _ -> failwith "Unreachable" - -(** Check if the ended regions of a comp projector over a symbolic value - intersect the regions listed in another projection *) -let symbolic_proj_comp_ended_regions_intersect_proj (s : V.symbolic_proj_comp) - (ty : T.rty) (regions : T.RegionId.set_t) : bool = - projections_intersect s.V.svalue.V.sv_ty s.V.rset_ended ty regions - -(** Check that a symbolic value doesn't contain ended regions. - - Note that we don't check that the set of ended regions is empty: we - check that the set of ended regions doesn't intersect the set of - regions used in the type (this is more general). -*) -let symbolic_proj_comp_ended_regions (s : V.symbolic_proj_comp) : bool = - let regions = rty_regions s.V.svalue.V.sv_ty in - not (T.RegionId.Set.disjoint regions s.rset_ended) - -(** Check if a [value] contains ⊥. - - Note that this function is very general: it also checks wether - symbolic values contain already ended regions. - *) -let bottom_in_value (v : V.typed_value) : bool = - let obj = - object - inherit [_] V.iter_typed_value - - method! visit_Bottom _ = raise Found - - method! visit_symbolic_proj_comp _ s = - if symbolic_proj_comp_ended_regions s then raise Found else () - end - in - (* We use exceptions *) - try - obj#visit_typed_value () v; - false - with Found -> true - -(** Check if an [avalue] contains ⊥. - - Note that this function is very general: it also checks wether - symbolic values contain already ended regions. - - TODO: remove? -*) -let bottom_in_avalue (v : V.typed_avalue) (_abs_regions : T.RegionId.set_t) : - bool = - let obj = - object - inherit [_] V.iter_typed_avalue - - method! visit_Bottom _ = raise Found - - method! visit_symbolic_proj_comp _ sv = - if symbolic_proj_comp_ended_regions sv then raise Found else () - - method! visit_aproj _ ap = - (* Nothing to do actually *) - match ap with - | V.AProjLoans _sv -> () - | V.AProjBorrows (_sv, _rty) -> () - end - in - (* We use exceptions *) - try - obj#visit_typed_avalue () v; - false - with Found -> true - -type outer_borrows_or_abs = - | OuterBorrows of borrow_ids - | OuterAbs of V.AbstractionId.id - -exception FoundOuter of outer_borrows_or_abs -(** Utility exception *) - -(** Auxiliary function. - - Apply a proj_borrows on a shared borrow. - In the case of shared borrows, we return [abstract_shared_borrows], - not avalues. -*) -let rec apply_proj_borrows_on_shared_borrow (ctx : C.eval_ctx) - (fresh_reborrow : V.BorrowId.id -> V.BorrowId.id) - (regions : T.RegionId.set_t) (v : V.typed_value) (ty : T.rty) : - V.abstract_shared_borrows = - (* Sanity check - TODO: move this elsewhere (here we perform the check at every - * recursive call which is a bit overkill...) *) - let ety = Substitute.erase_regions ty in - assert (ety = v.V.ty); - (* Project *) - match (v.V.value, ty) with - | V.Concrete _, (T.Bool | T.Char | T.Integer _ | T.Str) -> [] - | V.Adt adt, T.Adt (id, region_params, tys) -> - (* Retrieve the types of the fields *) - let field_types = - Subst.ctx_adt_value_get_instantiated_field_rtypes ctx adt id - region_params tys - in - (* Project over the field values *) - let fields_types = List.combine adt.V.field_values field_types in - let proj_fields = - List.map - (fun (fv, fty) -> - apply_proj_borrows_on_shared_borrow ctx fresh_reborrow regions fv - fty) - fields_types - in - List.concat proj_fields - | V.Bottom, _ -> failwith "Unreachable" - | V.Borrow bc, T.Ref (r, ref_ty, kind) -> - (* Retrieve the bid of the borrow and the asb of the projected borrowed value *) - let bid, asb = - (* Not in the set: dive *) - match (bc, kind) with - | V.MutBorrow (bid, bv), T.Mut -> - (* Apply the projection on the borrowed value *) - let asb = - apply_proj_borrows_on_shared_borrow ctx fresh_reborrow regions bv - ref_ty - in - (bid, asb) - | V.SharedBorrow bid, T.Shared -> - (* Lookup the shared value *) - let ek = ek_all in - let sv = lookup_loan ek bid ctx in - let asb = - match sv with - | _, Concrete (V.SharedLoan (_, sv)) - | _, Abstract (V.ASharedLoan (_, sv, _)) -> - apply_proj_borrows_on_shared_borrow ctx fresh_reborrow regions - sv ref_ty - | _ -> failwith "Unexpected" - in - (bid, asb) - | V.InactivatedMutBorrow _, _ -> - failwith - "Can't apply a proj_borrow over an inactivated mutable borrow" - | _ -> failwith "Unreachable" - in - let asb = - (* Check if the region is in the set of projected regions (note that - * we never project over static regions) *) - if region_in_set r regions then - let bid' = fresh_reborrow bid in - V.AsbBorrow bid' :: asb - else asb - in - asb - | V.Loan _, _ -> failwith "Unreachable" - | V.Symbolic s, _ -> - assert (not (symbolic_proj_comp_ended_regions_intersect_proj s ty regions)); - [ V.AsbProjReborrows (s.V.svalue, ty) ] - | _ -> failwith "Unreachable" - -(** Apply (and reduce) a projector over borrows to a value. - - - [regions]: the regions we project - - [v]: the value over which we project - - [ty]: the projection type (is used to map borrows to regions, or to - interpret the borrows as belonging to some regions...). Remember that - `v` doesn't contain region information. - For instance, if we have: - `v <: ty` where: - - `v = mut_borrow l ...` - - `ty = Ref (r, ...)` - then we interpret the borrow `l` as belonging to region `r` - - Also, when applying projections on shared values, we need to apply - reborrows. This is a bit annoying because, with the way we compute - the projection on borrows, we can't update the context immediately. - Instead, we remember the list of borrows we have to insert in the - context *afterwards*. - - [check_symbolic_no_ended] controls whether we check or not whether - symbolic values don't contain already ended regions. - This check is activated when applying projectors upon calling a function - (because we need to check that function arguments don't contain ⊥), - but deactivated when expanding symbolic values: - ``` - fn f<'a,'b>(x : &'a mut u32, y : &'b mut u32) -> (&'a mut u32, &'b mut u32); - - let p = f(&mut x, &mut y); // p -> @s0 - assert(x == ...); // end 'a - let z = p.1; // HERE: the symbolic expansion of @s0 contains ended regions - ``` -*) -let rec apply_proj_borrows (check_symbolic_no_ended : bool) (ctx : C.eval_ctx) - (fresh_reborrow : V.BorrowId.id -> V.BorrowId.id) - (regions : T.RegionId.set_t) (v : V.typed_value) (ty : T.rty) : - V.typed_avalue = - (* Sanity check - TODO: move this elsewhere (here we perform the check at every - * recursive call which is a bit overkill...) *) - let ety = Substitute.erase_regions ty in - assert (ety = v.V.ty); - (* Match *) - let value : V.avalue = - match (v.V.value, ty) with - | V.Concrete cv, (T.Bool | T.Char | T.Integer _ | T.Str) -> V.AConcrete cv - | V.Adt adt, T.Adt (id, region_params, tys) -> - (* Retrieve the types of the fields *) - let field_types = - Subst.ctx_adt_value_get_instantiated_field_rtypes ctx adt id - region_params tys - in - (* Project over the field values *) - let fields_types = List.combine adt.V.field_values field_types in - let proj_fields = - List.map - (fun (fv, fty) -> - apply_proj_borrows check_symbolic_no_ended ctx fresh_reborrow - regions fv fty) - fields_types - in - V.AAdt { V.variant_id = adt.V.variant_id; field_values = proj_fields } - | V.Bottom, _ -> failwith "Unreachable" - | V.Borrow bc, T.Ref (r, ref_ty, kind) -> - if - (* Check if the region is in the set of projected regions (note that - * we never project over static regions) *) - region_in_set r regions - then - (* In the set *) - let bc = - match (bc, kind) with - | V.MutBorrow (bid, bv), T.Mut -> - (* Apply the projection on the borrowed value *) - let bv = - apply_proj_borrows check_symbolic_no_ended ctx fresh_reborrow - regions bv ref_ty - in - V.AMutBorrow (bid, bv) - | V.SharedBorrow bid, T.Shared -> V.ASharedBorrow bid - | V.InactivatedMutBorrow _, _ -> - failwith - "Can't apply a proj_borrow over an inactivated mutable borrow" - | _ -> failwith "Unreachable" - in - V.ABorrow bc - else - (* Not in the set: ignore *) - let bc = - match (bc, kind) with - | V.MutBorrow (_bid, bv), T.Mut -> - (* Apply the projection on the borrowed value *) - let bv = - apply_proj_borrows check_symbolic_no_ended ctx fresh_reborrow - regions bv ref_ty - in - V.AIgnoredMutBorrow bv - | V.SharedBorrow bid, T.Shared -> - (* Lookup the shared value *) - let ek = ek_all in - let sv = lookup_loan ek bid ctx in - let asb = - match sv with - | _, Concrete (V.SharedLoan (_, sv)) - | _, Abstract (V.ASharedLoan (_, sv, _)) -> - apply_proj_borrows_on_shared_borrow ctx fresh_reborrow - regions sv ref_ty - | _ -> failwith "Unexpected" - in - V.AProjSharedBorrow asb - | V.InactivatedMutBorrow _, _ -> - failwith - "Can't apply a proj_borrow over an inactivated mutable borrow" - | _ -> failwith "Unreachable" - in - V.ABorrow bc - | V.Loan _, _ -> failwith "Unreachable" - | V.Symbolic s, _ -> - (* Check that the symbolic value doesn't contain already ended regions, - * if necessary *) - if check_symbolic_no_ended then - assert ( - not (symbolic_proj_comp_ended_regions_intersect_proj s ty regions)); - V.ASymbolic (V.AProjBorrows (s.V.svalue, ty)) - | _ -> failwith "Unreachable" - in - { V.value; V.ty } - -(** Convert a symbolic expansion *which is not a borrow* to a value *) -let symbolic_expansion_non_borrow_to_value (sv : V.symbolic_value) - (see : symbolic_expansion) : V.typed_value = - let ty = Subst.erase_regions sv.V.sv_ty in - let value = - match see with - | SeConcrete cv -> V.Concrete cv - | SeAdt (variant_id, field_values) -> - let field_values = - List.map mk_typed_value_from_proj_comp field_values - in - V.Adt { V.variant_id; V.field_values } - | SeMutRef (_, _) | SeSharedRef (_, _) -> - failwith "Unexpected symbolic reference expansion" - in - { V.value; V.ty } - -(** Convert a symbolic expansion to a value. - - If the expansion is a mutable reference expansion, it converts it to a borrow. - This function is meant to be used when reducing projectors over borrows, - during a symbolic expansion. - *) -let symbolic_expansion_non_shared_borrow_to_value (sv : V.symbolic_value) - (see : symbolic_expansion) : V.typed_value = - match see with - | SeMutRef (bid, bv) -> - let ty = Subst.erase_regions sv.V.sv_ty in - let bv = mk_typed_value_from_proj_comp bv in - let value = V.Borrow (V.MutBorrow (bid, bv)) in - { V.value; ty } - | SeSharedRef (_, _) -> - failwith "Unexpected symbolic shared reference expansion" - | _ -> symbolic_expansion_non_borrow_to_value sv see - -(** Apply (and reduce) a projector over loans to a value. - - TODO: detailed comments. See [apply_proj_borrows] -*) -let apply_proj_loans_on_symbolic_expansion (regions : T.RegionId.set_t) - (see : symbolic_expansion) (original_sv_ty : T.rty) : V.typed_avalue = - (* Match *) - let (value, ty) : V.avalue * T.rty = - match (see, original_sv_ty) with - | SeConcrete cv, (T.Bool | T.Char | T.Integer _ | T.Str) -> - (V.AConcrete cv, original_sv_ty) - | SeAdt (variant_id, field_values), T.Adt (_id, _region_params, _tys) -> - (* Project over the field values *) - let field_values = - List.map mk_aproj_loans_from_proj_comp field_values - in - (V.AAdt { V.variant_id; field_values }, original_sv_ty) - | SeMutRef (bid, spc), T.Ref (r, ref_ty, T.Mut) -> - (* Apply the projector to the borrowed value *) - let child_av = mk_aproj_loans_from_proj_comp spc in - (* Check if the region is in the set of projected regions (note that - * we never project over static regions) *) - if region_in_set r regions then - (* In the set: keep *) - (V.ALoan (V.AMutLoan (bid, child_av)), ref_ty) - else - (* Not in the set: ignore *) - (V.ALoan (V.AIgnoredMutLoan (bid, child_av)), ref_ty) - | SeSharedRef (bids, spc), T.Ref (r, ref_ty, T.Shared) -> - (* Apply the projector to the borrowed value *) - let child_av = mk_aproj_loans_from_proj_comp spc in - (* Check if the region is in the set of projected regions (note that - * we never project over static regions) *) - if region_in_set r regions then - (* In the set: keep *) - let shared_value = mk_typed_value_from_proj_comp spc in - (V.ALoan (V.ASharedLoan (bids, shared_value, child_av)), ref_ty) - else - (* Not in the set: ignore *) - (V.ALoan (V.AIgnoredSharedLoan child_av), ref_ty) - | _ -> failwith "Unreachable" - in - { V.value; V.ty } - (** Auxiliary function to end borrows: lookup a borrow in the environment, update it (by returning an updated environment where the borrow has been replaced by [Bottom])) if we can end the borrow (for instance, it is not @@ -672,196 +229,6 @@ let end_borrow_get_borrow (io : inner_outer) Ok (ctx, !replaced_bc) with FoundOuter outers -> Error outers -(** Auxiliary function. See [give_back_value]. - - Apply reborrows to a context. - - The [reborrows] input is a list of pairs (shared loan id, id to insert in the shared loan). -*) -let apply_reborrows (reborrows : (V.BorrowId.id * V.BorrowId.id) list) - (ctx : C.eval_ctx) : C.eval_ctx = - (* This is a bit brutal, but whenever we insert a reborrow, we remove - * it from the list. This allows us to check that all the reborrows were - * applied before returning. - * We might reimplement that in a more efficient manner by using maps. *) - let reborrows = ref reborrows in - - (* Check if a value is a mutable borrow, and return its identifier if - it is the case *) - let get_borrow_in_mut_borrow (v : V.typed_value) : V.BorrowId.id option = - match v.V.value with - | V.Borrow lc -> ( - match lc with - | V.SharedBorrow _ | V.InactivatedMutBorrow _ -> None - | V.MutBorrow (id, _) -> Some id) - | _ -> None - in - - (* Add the proper reborrows to a set of borrow ids (for a shared loan) *) - let insert_reborrows bids = - (* Find the reborrows to apply *) - let insert, reborrows' = - List.partition (fun (bid, _) -> V.BorrowId.Set.mem bid bids) !reborrows - in - reborrows := reborrows'; - let insert = List.map snd insert in - (* Insert the borrows *) - List.fold_left (fun bids bid -> V.BorrowId.Set.add bid bids) bids insert - in - - (* Get the list of reborrows for a given borrow id *) - let get_reborrows_for_bid bid = - (* Find the reborrows to apply *) - let insert, reborrows' = - List.partition (fun (bid', _) -> bid' = bid) !reborrows - in - reborrows := reborrows'; - List.map snd insert - in - - let borrows_to_set bids = - List.fold_left - (fun bids bid -> V.BorrowId.Set.add bid bids) - V.BorrowId.Set.empty bids - in - - (* Insert reborrows for a given borrow id into a given set of borrows *) - let insert_reborrows_for_bid bids bid = - (* Find the reborrows to apply *) - let insert = get_reborrows_for_bid bid in - (* Insert the borrows *) - List.fold_left (fun bids bid -> V.BorrowId.Set.add bid bids) bids insert - in - - let obj = - object - inherit [_] C.map_eval_ctx as super - - method! visit_typed_value env v = - match v.V.value with - | V.Borrow (V.MutBorrow (bid, bv)) -> - let insert = get_reborrows_for_bid bid in - let nbc = super#visit_MutBorrow env bid bv in - let nbc = { v with V.value = V.Borrow nbc } in - if insert = [] then (* No reborrows: do nothing special *) - nbc - else - (* There are reborrows: insert a shared loan *) - let insert = borrows_to_set insert in - let value = V.Loan (V.SharedLoan (insert, nbc)) in - let ty = v.V.ty in - { V.value; ty } - | _ -> super#visit_typed_value env v - (** We may need to reborrow mutable borrows. Note that this doesn't - happen for aborrows *) - - method! visit_loan_content env lc = - match lc with - | V.SharedLoan (bids, sv) -> - (* Insert the reborrows *) - let bids = insert_reborrows bids in - (* Check if the contained value is a mutable borrow, in which - * case we might need to reborrow it by adding more borrow ids - * to the current set of borrows - by doing this small - * manipulation here, we accumulate the borrow ids in the same - * shared loan, right above the mutable borrow, and avoid - * stacking shared loans (note that doing this is not a problem - * from a soundness point of view, but it is a bit ugly...) *) - let bids = - match get_borrow_in_mut_borrow sv with - | None -> bids - | Some bid -> insert_reborrows_for_bid bids bid - in - (* Update and explore *) - super#visit_SharedLoan env bids sv - | V.MutLoan bid -> - (* Nothing special to do *) - super#visit_MutLoan env bid - (** We reimplement [visit_loan_content] (rather than one of the sub- - functions) on purpose: exhaustive matches are good for maintenance *) - - method! visit_aloan_content env lc = - (* TODO: ashared_loan (amut_loan ) case *) - match lc with - | V.ASharedLoan (bids, v, av) -> - (* Insert the reborrows *) - let bids = insert_reborrows bids in - (* Update and explore *) - super#visit_ASharedLoan env bids v av - | V.AIgnoredSharedLoan _ - | V.AMutLoan (_, _) - | V.AEndedMutLoan { given_back = _; child = _ } - | V.AEndedSharedLoan (_, _) - | V.AIgnoredMutLoan (_, _) - | V.AEndedIgnoredMutLoan { given_back = _; child = _ } -> - (* Nothing particular to do *) - super#visit_aloan_content env lc - end - in - - (* Visit *) - let ctx = obj#visit_eval_ctx () ctx in - (* Check that there are no reborrows remaining *) - assert (!reborrows = []); - (* Return *) - ctx - -(** Auxiliary function to prepare reborrowing operations (used when - applying projectors). - - Returns two functions: - - a function to generate fresh re-borrow ids, and register the reborrows - - a function to apply the reborrows in a context - Those functions are of course stateful. - *) -let prepare_reborrows (config : C.config) (allow_reborrows : bool) - (ctx : C.eval_ctx) : - (V.BorrowId.id -> V.BorrowId.id) * (C.eval_ctx -> C.eval_ctx) = - let reborrows : (V.BorrowId.id * V.BorrowId.id) list ref = ref [] in - let borrow_counter = ref ctx.C.borrow_counter in - (* The function to generate and register fresh reborrows *) - let fresh_reborrow (bid : V.BorrowId.id) : V.BorrowId.id = - if allow_reborrows then ( - let bid', cnt' = V.BorrowId.fresh !borrow_counter in - borrow_counter := cnt'; - reborrows := (bid, bid') :: !reborrows; - bid') - else failwith "Unexpected reborrow" - in - (* The function to apply the reborrows in a context *) - let apply_registered_reborrows (ctx : C.eval_ctx) : C.eval_ctx = - match config.C.mode with - | C.ConcreteMode -> - (* Reborrows are introduced when applying projections in symbolic mode *) - assert (!borrow_counter = ctx.C.borrow_counter); - assert (!reborrows = []); - ctx - | C.SymbolicMode -> - (* Update the borrow counter *) - let ctx = { ctx with C.borrow_counter = !borrow_counter } in - (* Apply the reborrows *) - apply_reborrows !reborrows ctx - in - (fresh_reborrow, apply_registered_reborrows) - -let apply_proj_borrows_on_input_value (config : C.config) (ctx : C.eval_ctx) - (regions : T.RegionId.set_t) (v : V.typed_value) (ty : T.rty) : - C.eval_ctx * V.typed_avalue = - let check_symbolic_no_ended = true in - let allow_reborrows = true in - (* Prepare the reborrows *) - let fresh_reborrow, apply_registered_reborrows = - prepare_reborrows config allow_reborrows ctx - in - (* Apply the projector *) - let av = - apply_proj_borrows check_symbolic_no_ended ctx fresh_reborrow regions v ty - in - (* Apply the reborrows *) - let ctx = apply_registered_reborrows ctx in - (* Return *) - (ctx, av) - (** Auxiliary function to end borrows. See [give_back]. When we end a mutable borrow, we need to "give back" the value it contained diff --git a/src/InterpreterProjectors.ml b/src/InterpreterProjectors.ml new file mode 100644 index 00000000..9c99f8c9 --- /dev/null +++ b/src/InterpreterProjectors.ml @@ -0,0 +1,505 @@ +module T = Types +module V = Values +open Scalars +module E = Expressions +open Errors +module C = Contexts +module Subst = Substitute +module A = CfimAst +module L = Logging +open TypesUtils +open ValuesUtils +module Inv = Invariants +module S = Synthesis +open Utils +open InterpreterUtils + +(** Auxiliary function. + + Apply a proj_borrows on a shared borrow. + In the case of shared borrows, we return [abstract_shared_borrows], + not avalues. +*) +let rec apply_proj_borrows_on_shared_borrow (ctx : C.eval_ctx) + (fresh_reborrow : V.BorrowId.id -> V.BorrowId.id) + (regions : T.RegionId.set_t) (v : V.typed_value) (ty : T.rty) : + V.abstract_shared_borrows = + (* Sanity check - TODO: move this elsewhere (here we perform the check at every + * recursive call which is a bit overkill...) *) + let ety = Substitute.erase_regions ty in + assert (ety = v.V.ty); + (* Project *) + match (v.V.value, ty) with + | V.Concrete _, (T.Bool | T.Char | T.Integer _ | T.Str) -> [] + | V.Adt adt, T.Adt (id, region_params, tys) -> + (* Retrieve the types of the fields *) + let field_types = + Subst.ctx_adt_value_get_instantiated_field_rtypes ctx adt id + region_params tys + in + (* Project over the field values *) + let fields_types = List.combine adt.V.field_values field_types in + let proj_fields = + List.map + (fun (fv, fty) -> + apply_proj_borrows_on_shared_borrow ctx fresh_reborrow regions fv + fty) + fields_types + in + List.concat proj_fields + | V.Bottom, _ -> failwith "Unreachable" + | V.Borrow bc, T.Ref (r, ref_ty, kind) -> + (* Retrieve the bid of the borrow and the asb of the projected borrowed value *) + let bid, asb = + (* Not in the set: dive *) + match (bc, kind) with + | V.MutBorrow (bid, bv), T.Mut -> + (* Apply the projection on the borrowed value *) + let asb = + apply_proj_borrows_on_shared_borrow ctx fresh_reborrow regions bv + ref_ty + in + (bid, asb) + | V.SharedBorrow bid, T.Shared -> + (* Lookup the shared value *) + let ek = ek_all in + let sv = lookup_loan ek bid ctx in + let asb = + match sv with + | _, Concrete (V.SharedLoan (_, sv)) + | _, Abstract (V.ASharedLoan (_, sv, _)) -> + apply_proj_borrows_on_shared_borrow ctx fresh_reborrow regions + sv ref_ty + | _ -> failwith "Unexpected" + in + (bid, asb) + | V.InactivatedMutBorrow _, _ -> + failwith + "Can't apply a proj_borrow over an inactivated mutable borrow" + | _ -> failwith "Unreachable" + in + let asb = + (* Check if the region is in the set of projected regions (note that + * we never project over static regions) *) + if region_in_set r regions then + let bid' = fresh_reborrow bid in + V.AsbBorrow bid' :: asb + else asb + in + asb + | V.Loan _, _ -> failwith "Unreachable" + | V.Symbolic s, _ -> + assert (not (symbolic_proj_comp_ended_regions_intersect_proj s ty regions)); + [ V.AsbProjReborrows (s.V.svalue, ty) ] + | _ -> failwith "Unreachable" + +(** Apply (and reduce) a projector over borrows to a value. + + - [regions]: the regions we project + - [v]: the value over which we project + - [ty]: the projection type (is used to map borrows to regions, or to + interpret the borrows as belonging to some regions...). Remember that + `v` doesn't contain region information. + For instance, if we have: + `v <: ty` where: + - `v = mut_borrow l ...` + - `ty = Ref (r, ...)` + then we interpret the borrow `l` as belonging to region `r` + + Also, when applying projections on shared values, we need to apply + reborrows. This is a bit annoying because, with the way we compute + the projection on borrows, we can't update the context immediately. + Instead, we remember the list of borrows we have to insert in the + context *afterwards*. + + [check_symbolic_no_ended] controls whether we check or not whether + symbolic values don't contain already ended regions. + This check is activated when applying projectors upon calling a function + (because we need to check that function arguments don't contain ⊥), + but deactivated when expanding symbolic values: + ``` + fn f<'a,'b>(x : &'a mut u32, y : &'b mut u32) -> (&'a mut u32, &'b mut u32); + + let p = f(&mut x, &mut y); // p -> @s0 + assert(x == ...); // end 'a + let z = p.1; // HERE: the symbolic expansion of @s0 contains ended regions + ``` +*) +let rec apply_proj_borrows (check_symbolic_no_ended : bool) (ctx : C.eval_ctx) + (fresh_reborrow : V.BorrowId.id -> V.BorrowId.id) + (regions : T.RegionId.set_t) (v : V.typed_value) (ty : T.rty) : + V.typed_avalue = + (* Sanity check - TODO: move this elsewhere (here we perform the check at every + * recursive call which is a bit overkill...) *) + let ety = Substitute.erase_regions ty in + assert (ety = v.V.ty); + (* Match *) + let value : V.avalue = + match (v.V.value, ty) with + | V.Concrete cv, (T.Bool | T.Char | T.Integer _ | T.Str) -> V.AConcrete cv + | V.Adt adt, T.Adt (id, region_params, tys) -> + (* Retrieve the types of the fields *) + let field_types = + Subst.ctx_adt_value_get_instantiated_field_rtypes ctx adt id + region_params tys + in + (* Project over the field values *) + let fields_types = List.combine adt.V.field_values field_types in + let proj_fields = + List.map + (fun (fv, fty) -> + apply_proj_borrows check_symbolic_no_ended ctx fresh_reborrow + regions fv fty) + fields_types + in + V.AAdt { V.variant_id = adt.V.variant_id; field_values = proj_fields } + | V.Bottom, _ -> failwith "Unreachable" + | V.Borrow bc, T.Ref (r, ref_ty, kind) -> + if + (* Check if the region is in the set of projected regions (note that + * we never project over static regions) *) + region_in_set r regions + then + (* In the set *) + let bc = + match (bc, kind) with + | V.MutBorrow (bid, bv), T.Mut -> + (* Apply the projection on the borrowed value *) + let bv = + apply_proj_borrows check_symbolic_no_ended ctx fresh_reborrow + regions bv ref_ty + in + V.AMutBorrow (bid, bv) + | V.SharedBorrow bid, T.Shared -> V.ASharedBorrow bid + | V.InactivatedMutBorrow _, _ -> + failwith + "Can't apply a proj_borrow over an inactivated mutable borrow" + | _ -> failwith "Unreachable" + in + V.ABorrow bc + else + (* Not in the set: ignore *) + let bc = + match (bc, kind) with + | V.MutBorrow (_bid, bv), T.Mut -> + (* Apply the projection on the borrowed value *) + let bv = + apply_proj_borrows check_symbolic_no_ended ctx fresh_reborrow + regions bv ref_ty + in + V.AIgnoredMutBorrow bv + | V.SharedBorrow bid, T.Shared -> + (* Lookup the shared value *) + let ek = ek_all in + let sv = lookup_loan ek bid ctx in + let asb = + match sv with + | _, Concrete (V.SharedLoan (_, sv)) + | _, Abstract (V.ASharedLoan (_, sv, _)) -> + apply_proj_borrows_on_shared_borrow ctx fresh_reborrow + regions sv ref_ty + | _ -> failwith "Unexpected" + in + V.AProjSharedBorrow asb + | V.InactivatedMutBorrow _, _ -> + failwith + "Can't apply a proj_borrow over an inactivated mutable borrow" + | _ -> failwith "Unreachable" + in + V.ABorrow bc + | V.Loan _, _ -> failwith "Unreachable" + | V.Symbolic s, _ -> + (* Check that the symbolic value doesn't contain already ended regions, + * if necessary *) + if check_symbolic_no_ended then + assert ( + not (symbolic_proj_comp_ended_regions_intersect_proj s ty regions)); + V.ASymbolic (V.AProjBorrows (s.V.svalue, ty)) + | _ -> failwith "Unreachable" + in + { V.value; V.ty } + +(** Convert a symbolic expansion *which is not a borrow* to a value *) +let symbolic_expansion_non_borrow_to_value (sv : V.symbolic_value) + (see : symbolic_expansion) : V.typed_value = + let ty = Subst.erase_regions sv.V.sv_ty in + let value = + match see with + | SeConcrete cv -> V.Concrete cv + | SeAdt (variant_id, field_values) -> + let field_values = + List.map mk_typed_value_from_proj_comp field_values + in + V.Adt { V.variant_id; V.field_values } + | SeMutRef (_, _) | SeSharedRef (_, _) -> + failwith "Unexpected symbolic reference expansion" + in + { V.value; V.ty } + +(** Convert a symbolic expansion to a value. + + If the expansion is a mutable reference expansion, it converts it to a borrow. + This function is meant to be used when reducing projectors over borrows, + during a symbolic expansion. + *) +let symbolic_expansion_non_shared_borrow_to_value (sv : V.symbolic_value) + (see : symbolic_expansion) : V.typed_value = + match see with + | SeMutRef (bid, bv) -> + let ty = Subst.erase_regions sv.V.sv_ty in + let bv = mk_typed_value_from_proj_comp bv in + let value = V.Borrow (V.MutBorrow (bid, bv)) in + { V.value; ty } + | SeSharedRef (_, _) -> + failwith "Unexpected symbolic shared reference expansion" + | _ -> symbolic_expansion_non_borrow_to_value sv see + +(** Apply (and reduce) a projector over loans to a value. + + TODO: detailed comments. See [apply_proj_borrows] +*) +let apply_proj_loans_on_symbolic_expansion (regions : T.RegionId.set_t) + (see : symbolic_expansion) (original_sv_ty : T.rty) : V.typed_avalue = + (* Match *) + let (value, ty) : V.avalue * T.rty = + match (see, original_sv_ty) with + | SeConcrete cv, (T.Bool | T.Char | T.Integer _ | T.Str) -> + (V.AConcrete cv, original_sv_ty) + | SeAdt (variant_id, field_values), T.Adt (_id, _region_params, _tys) -> + (* Project over the field values *) + let field_values = + List.map mk_aproj_loans_from_proj_comp field_values + in + (V.AAdt { V.variant_id; field_values }, original_sv_ty) + | SeMutRef (bid, spc), T.Ref (r, ref_ty, T.Mut) -> + (* Apply the projector to the borrowed value *) + let child_av = mk_aproj_loans_from_proj_comp spc in + (* Check if the region is in the set of projected regions (note that + * we never project over static regions) *) + if region_in_set r regions then + (* In the set: keep *) + (V.ALoan (V.AMutLoan (bid, child_av)), ref_ty) + else + (* Not in the set: ignore *) + (V.ALoan (V.AIgnoredMutLoan (bid, child_av)), ref_ty) + | SeSharedRef (bids, spc), T.Ref (r, ref_ty, T.Shared) -> + (* Apply the projector to the borrowed value *) + let child_av = mk_aproj_loans_from_proj_comp spc in + (* Check if the region is in the set of projected regions (note that + * we never project over static regions) *) + if region_in_set r regions then + (* In the set: keep *) + let shared_value = mk_typed_value_from_proj_comp spc in + (V.ALoan (V.ASharedLoan (bids, shared_value, child_av)), ref_ty) + else + (* Not in the set: ignore *) + (V.ALoan (V.AIgnoredSharedLoan child_av), ref_ty) + | _ -> failwith "Unreachable" + in + { V.value; V.ty } + +(** Auxiliary function. See [give_back_value]. + + Apply reborrows to a context. + + The [reborrows] input is a list of pairs (shared loan id, id to insert + in the shared loan). + This function is used when applying projectors on shared borrows: when + doing so, we might need to reborrow subvalues from the shared value. + For instance: + ``` + fn f<'a,'b,'c>(x : &'a 'b 'c u32) + ``` + When introducing the abstractions for 'a, 'b and 'c, we apply a projector + on some value `shared_borrow l : &'a &'b &'c u32`. + In the 'a abstraction, this shared borrow gets projected. However, when + reducing the projectors for the 'b and 'c abstractions, we need to make + sure that the borrows living in regions 'b and 'c live as long as those + regions. This is done by looking up the shared value and applying reborrows + on the borrows we find there (note that those reborrows apply on shared + borrows - easy - and mutable borrows - in this case, we reborrow the whole + borrow: `mut_borrow ... ~~> shared_loan {...} (mut_borrow ...)`). +*) +let apply_reborrows (reborrows : (V.BorrowId.id * V.BorrowId.id) list) + (ctx : C.eval_ctx) : C.eval_ctx = + (* This is a bit brutal, but whenever we insert a reborrow, we remove + * it from the list. This allows us to check that all the reborrows were + * applied before returning. + * We might reimplement that in a more efficient manner by using maps. *) + let reborrows = ref reborrows in + + (* Check if a value is a mutable borrow, and return its identifier if + it is the case *) + let get_borrow_in_mut_borrow (v : V.typed_value) : V.BorrowId.id option = + match v.V.value with + | V.Borrow lc -> ( + match lc with + | V.SharedBorrow _ | V.InactivatedMutBorrow _ -> None + | V.MutBorrow (id, _) -> Some id) + | _ -> None + in + + (* Add the proper reborrows to a set of borrow ids (for a shared loan) *) + let insert_reborrows bids = + (* Find the reborrows to apply *) + let insert, reborrows' = + List.partition (fun (bid, _) -> V.BorrowId.Set.mem bid bids) !reborrows + in + reborrows := reborrows'; + let insert = List.map snd insert in + (* Insert the borrows *) + List.fold_left (fun bids bid -> V.BorrowId.Set.add bid bids) bids insert + in + + (* Get the list of reborrows for a given borrow id *) + let get_reborrows_for_bid bid = + (* Find the reborrows to apply *) + let insert, reborrows' = + List.partition (fun (bid', _) -> bid' = bid) !reborrows + in + reborrows := reborrows'; + List.map snd insert + in + + let borrows_to_set bids = + List.fold_left + (fun bids bid -> V.BorrowId.Set.add bid bids) + V.BorrowId.Set.empty bids + in + + (* Insert reborrows for a given borrow id into a given set of borrows *) + let insert_reborrows_for_bid bids bid = + (* Find the reborrows to apply *) + let insert = get_reborrows_for_bid bid in + (* Insert the borrows *) + List.fold_left (fun bids bid -> V.BorrowId.Set.add bid bids) bids insert + in + + let obj = + object + inherit [_] C.map_eval_ctx as super + + method! visit_typed_value env v = + match v.V.value with + | V.Borrow (V.MutBorrow (bid, bv)) -> + let insert = get_reborrows_for_bid bid in + let nbc = super#visit_MutBorrow env bid bv in + let nbc = { v with V.value = V.Borrow nbc } in + if insert = [] then (* No reborrows: do nothing special *) + nbc + else + (* There are reborrows: insert a shared loan *) + let insert = borrows_to_set insert in + let value = V.Loan (V.SharedLoan (insert, nbc)) in + let ty = v.V.ty in + { V.value; ty } + | _ -> super#visit_typed_value env v + (** We may need to reborrow mutable borrows. Note that this doesn't + happen for aborrows *) + + method! visit_loan_content env lc = + match lc with + | V.SharedLoan (bids, sv) -> + (* Insert the reborrows *) + let bids = insert_reborrows bids in + (* Check if the contained value is a mutable borrow, in which + * case we might need to reborrow it by adding more borrow ids + * to the current set of borrows - by doing this small + * manipulation here, we accumulate the borrow ids in the same + * shared loan, right above the mutable borrow, and avoid + * stacking shared loans (note that doing this is not a problem + * from a soundness point of view, but it is a bit ugly...) *) + let bids = + match get_borrow_in_mut_borrow sv with + | None -> bids + | Some bid -> insert_reborrows_for_bid bids bid + in + (* Update and explore *) + super#visit_SharedLoan env bids sv + | V.MutLoan bid -> + (* Nothing special to do *) + super#visit_MutLoan env bid + (** We reimplement [visit_loan_content] (rather than one of the sub- + functions) on purpose: exhaustive matches are good for maintenance *) + + method! visit_aloan_content env lc = + (* TODO: ashared_loan (amut_loan ) case *) + match lc with + | V.ASharedLoan (bids, v, av) -> + (* Insert the reborrows *) + let bids = insert_reborrows bids in + (* Update and explore *) + super#visit_ASharedLoan env bids v av + | V.AIgnoredSharedLoan _ + | V.AMutLoan (_, _) + | V.AEndedMutLoan { given_back = _; child = _ } + | V.AEndedSharedLoan (_, _) + | V.AIgnoredMutLoan (_, _) + | V.AEndedIgnoredMutLoan { given_back = _; child = _ } -> + (* Nothing particular to do *) + super#visit_aloan_content env lc + end + in + + (* Visit *) + let ctx = obj#visit_eval_ctx () ctx in + (* Check that there are no reborrows remaining *) + assert (!reborrows = []); + (* Return *) + ctx + +(** Auxiliary function to prepare reborrowing operations (used when + applying projectors). + + Returns two functions: + - a function to generate fresh re-borrow ids, and register the reborrows + - a function to apply the reborrows in a context + Those functions are of course stateful. + *) +let prepare_reborrows (config : C.config) (allow_reborrows : bool) + (ctx : C.eval_ctx) : + (V.BorrowId.id -> V.BorrowId.id) * (C.eval_ctx -> C.eval_ctx) = + let reborrows : (V.BorrowId.id * V.BorrowId.id) list ref = ref [] in + let borrow_counter = ref ctx.C.borrow_counter in + (* The function to generate and register fresh reborrows *) + let fresh_reborrow (bid : V.BorrowId.id) : V.BorrowId.id = + if allow_reborrows then ( + let bid', cnt' = V.BorrowId.fresh !borrow_counter in + borrow_counter := cnt'; + reborrows := (bid, bid') :: !reborrows; + bid') + else failwith "Unexpected reborrow" + in + (* The function to apply the reborrows in a context *) + let apply_registered_reborrows (ctx : C.eval_ctx) : C.eval_ctx = + match config.C.mode with + | C.ConcreteMode -> + (* Reborrows are introduced when applying projections in symbolic mode *) + assert (!borrow_counter = ctx.C.borrow_counter); + assert (!reborrows = []); + ctx + | C.SymbolicMode -> + (* Update the borrow counter *) + let ctx = { ctx with C.borrow_counter = !borrow_counter } in + (* Apply the reborrows *) + apply_reborrows !reborrows ctx + in + (fresh_reborrow, apply_registered_reborrows) + +let apply_proj_borrows_on_input_value (config : C.config) (ctx : C.eval_ctx) + (regions : T.RegionId.set_t) (v : V.typed_value) (ty : T.rty) : + C.eval_ctx * V.typed_avalue = + let check_symbolic_no_ended = true in + let allow_reborrows = true in + (* Prepare the reborrows *) + let fresh_reborrow, apply_registered_reborrows = + prepare_reborrows config allow_reborrows ctx + in + (* Apply the projector *) + let av = + apply_proj_borrows check_symbolic_no_ended ctx fresh_reborrow regions v ty + in + (* Apply the reborrows *) + let ctx = apply_registered_reborrows ctx in + (* Return *) + (ctx, av) diff --git a/src/InterpreterUtils.ml b/src/InterpreterUtils.ml index edc8594c..c652a1d3 100644 --- a/src/InterpreterUtils.ml +++ b/src/InterpreterUtils.ml @@ -632,3 +632,163 @@ type symbolic_expansion = | SeAdt of (T.VariantId.id option * V.symbolic_proj_comp list) | SeMutRef of V.BorrowId.id * V.symbolic_proj_comp | SeSharedRef of V.BorrowId.set_t * V.symbolic_proj_comp + +(** The following type identifies the relative position of expressions (in + particular borrows) in other expressions. + + For instance, it is used to control [end_borrow]: we usually only allow + to end "outer" borrows, unless we perform a drop. +*) +type inner_outer = Inner | Outer + +type borrow_ids = Borrows of V.BorrowId.Set.t | Borrow of V.BorrowId.id + +exception FoundBorrowIds of borrow_ids + +let update_if_none opt x = match opt with None -> Some x | _ -> opt + +(** Auxiliary function: see its usage in [end_borrow_get_borrow_in_value] *) +let update_outer_borrows (io : inner_outer) + (outer : V.AbstractionId.id option * borrow_ids option) (x : borrow_ids) : + V.AbstractionId.id option * borrow_ids option = + match io with + | Inner -> + (* If we can end inner borrows, we don't keep track of the outer borrows *) + outer + | Outer -> + let abs, opt = outer in + (abs, update_if_none opt x) + +(** Return the first loan we find in a value *) +let get_first_loan_in_value (v : V.typed_value) : V.loan_content option = + let obj = + object + inherit [_] V.iter_typed_value + + method! visit_loan_content _ lc = raise (FoundLoanContent lc) + end + in + (* We use exceptions *) + try + obj#visit_typed_value () v; + None + with FoundLoanContent lc -> Some lc + +(** Check if two different projections intersect. This is necessary when + giving a symbolic value to an abstraction: we need to check that + the regions which are already ended inside the abstraction don't + intersect the regions over which we project in the new abstraction. + Note that the two abstractions have different views (in terms of regions) + of the symbolic value (hence the two region types). +*) +let rec projections_intersect (ty1 : T.rty) (rset1 : T.RegionId.set_t) + (ty2 : T.rty) (rset2 : T.RegionId.set_t) : bool = + match (ty1, ty2) with + | T.Bool, T.Bool | T.Char, T.Char | T.Str, T.Str -> false + | T.Integer int_ty1, T.Integer int_ty2 -> + assert (int_ty1 = int_ty2); + false + | T.Adt (id1, regions1, tys1), T.Adt (id2, regions2, tys2) -> + assert (id1 = id2); + (* The intersection check for the ADTs is very crude: + * we check if some arguments intersect. As all the type and region + * parameters should be used somewhere in the ADT (otherwise rustc + * generates an error), it means that it should be equivalent to checking + * whether two fields intersect (and anyway comparing the field types is + * difficult in case of enumerations...). + * If we didn't have the above property enforced by the rust compiler, + * this check would still be a reasonable conservative approximation. *) + let regions = List.combine regions1 regions2 in + let tys = List.combine tys1 tys2 in + List.exists + (fun (r1, r2) -> region_in_set r1 rset1 && region_in_set r2 rset2) + regions + || List.exists + (fun (ty1, ty2) -> projections_intersect ty1 rset1 ty2 rset2) + tys + | T.Array ty1, T.Array ty2 | T.Slice ty1, T.Slice ty2 -> + projections_intersect ty1 rset1 ty2 rset2 + | T.Ref (r1, ty1, kind1), T.Ref (r2, ty2, kind2) -> + (* Sanity check *) + assert (kind1 = kind2); + (* The projections intersect if the borrows intersect or their contents + * intersect *) + (region_in_set r1 rset1 && region_in_set r2 rset2) + || projections_intersect ty1 rset1 ty2 rset2 + | _ -> failwith "Unreachable" + +(** Check if the ended regions of a comp projector over a symbolic value + intersect the regions listed in another projection *) +let symbolic_proj_comp_ended_regions_intersect_proj (s : V.symbolic_proj_comp) + (ty : T.rty) (regions : T.RegionId.set_t) : bool = + projections_intersect s.V.svalue.V.sv_ty s.V.rset_ended ty regions + +(** Check that a symbolic value doesn't contain ended regions. + + Note that we don't check that the set of ended regions is empty: we + check that the set of ended regions doesn't intersect the set of + regions used in the type (this is more general). +*) +let symbolic_proj_comp_ended_regions (s : V.symbolic_proj_comp) : bool = + let regions = rty_regions s.V.svalue.V.sv_ty in + not (T.RegionId.Set.disjoint regions s.rset_ended) + +(** Check if a [value] contains ⊥. + + Note that this function is very general: it also checks wether + symbolic values contain already ended regions. + *) +let bottom_in_value (v : V.typed_value) : bool = + let obj = + object + inherit [_] V.iter_typed_value + + method! visit_Bottom _ = raise Found + + method! visit_symbolic_proj_comp _ s = + if symbolic_proj_comp_ended_regions s then raise Found else () + end + in + (* We use exceptions *) + try + obj#visit_typed_value () v; + false + with Found -> true + +(** Check if an [avalue] contains ⊥. + + Note that this function is very general: it also checks wether + symbolic values contain already ended regions. + + TODO: remove? +*) +let bottom_in_avalue (v : V.typed_avalue) (_abs_regions : T.RegionId.set_t) : + bool = + let obj = + object + inherit [_] V.iter_typed_avalue + + method! visit_Bottom _ = raise Found + + method! visit_symbolic_proj_comp _ sv = + if symbolic_proj_comp_ended_regions sv then raise Found else () + + method! visit_aproj _ ap = + (* Nothing to do actually *) + match ap with + | V.AProjLoans _sv -> () + | V.AProjBorrows (_sv, _rty) -> () + end + in + (* We use exceptions *) + try + obj#visit_typed_avalue () v; + false + with Found -> true + +type outer_borrows_or_abs = + | OuterBorrows of borrow_ids + | OuterAbs of V.AbstractionId.id + +exception FoundOuter of outer_borrows_or_abs +(** Utility exception *) -- cgit v1.2.3 From 5bc1e789dd19ca3c639fd0fd9c7d5ea93e9b8634 Mon Sep 17 00:00:00 2001 From: Son Ho Date: Thu, 6 Jan 2022 10:25:21 +0100 Subject: Move some functions from Interpreter to InterpreterBorrows --- src/Interpreter.ml | 1100 +------------------------------------------- src/InterpreterBorrows.ml | 1115 +++++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 1116 insertions(+), 1099 deletions(-) create mode 100644 src/InterpreterBorrows.ml (limited to 'src') diff --git a/src/Interpreter.ml b/src/Interpreter.ml index afe513be..7dc37dff 100644 --- a/src/Interpreter.ml +++ b/src/Interpreter.ml @@ -14,6 +14,7 @@ module S = Synthesis open Utils open InterpreterUtils open InterpreterProjectors +open InterpreterBorrows (* TODO: check that the value types are correct when evaluating *) (* TODO: for debugging purposes, we might want to put use eval_ctx everywhere @@ -35,1105 +36,6 @@ type eval_error = Panic type 'a eval_result = ('a, eval_error) result -(** Auxiliary function to end borrows: lookup a borrow in the environment, - update it (by returning an updated environment where the borrow has been - replaced by [Bottom])) if we can end the borrow (for instance, it is not - an outer borrow...) or return the reason why we couldn't update the borrow. - - [end_borrow] then simply performs a loop: as long as we need to end (outer) - borrows, we end them, before finally ending the borrow we wanted to end in the - first place. - - Note that it is possible to end a borrow in an abstraction, without ending - the whole abstraction, if the corresponding loan is inside the abstraction - as well. The [allowed_abs] parameter controls whether we allow to end borrows - in an abstraction or not, and in which abstraction. -*) -let end_borrow_get_borrow (io : inner_outer) - (allowed_abs : V.AbstractionId.id option) (l : V.BorrowId.id) - (ctx : C.eval_ctx) : - (C.eval_ctx * g_borrow_content option, outer_borrows_or_abs) result = - (* We use a reference to communicate the kind of borrow we found, if we - * find one *) - let replaced_bc : g_borrow_content option ref = ref None in - let set_replaced_bc (bc : g_borrow_content) = - assert (Option.is_none !replaced_bc); - replaced_bc := Some bc - in - (* Raise an exception if there are outer borrows or if we are inside an - * abstraction: this exception is caught in a wrapper function *) - let raise_if_outer (outer : V.AbstractionId.id option * borrow_ids option) = - let outer_abs, outer_borrows = outer in - match outer_abs with - | Some abs -> ( - if - (* Check if we can end borrows inside this abstraction *) - Some abs <> allowed_abs - then raise (FoundOuter (OuterAbs abs)) - else - match outer_borrows with - | Some borrows -> raise (FoundOuter (OuterBorrows borrows)) - | None -> ()) - | None -> ( - match outer_borrows with - | Some borrows -> raise (FoundOuter (OuterBorrows borrows)) - | None -> ()) - in - - (* The environment is used to keep track of the outer loans *) - let obj = - object - inherit [_] C.map_eval_ctx as super - - method! visit_Loan (outer : V.AbstractionId.id option * borrow_ids option) - lc = - match lc with - | V.MutLoan bid -> V.Loan (super#visit_MutLoan outer bid) - | V.SharedLoan (bids, v) -> - (* Update the outer borrows before diving into the shared value *) - let outer = update_outer_borrows io outer (Borrows bids) in - V.Loan (super#visit_SharedLoan outer bids v) - (** We reimplement [visit_Loan] because we may have to update the - outer borrows *) - - method! visit_Borrow outer bc = - match bc with - | SharedBorrow l' | InactivatedMutBorrow l' -> - (* Check if this is the borrow we are looking for *) - if l = l' then ( - (* Check if there are outer borrows or if we are inside an abstraction *) - raise_if_outer outer; - (* Register the update *) - set_replaced_bc (Concrete bc); - (* Update the value *) - V.Bottom) - else super#visit_Borrow outer bc - | V.MutBorrow (l', bv) -> - (* Check if this is the borrow we are looking for *) - if l = l' then ( - (* Check if there are outer borrows or if we are inside an abstraction *) - raise_if_outer outer; - (* Register the update *) - set_replaced_bc (Concrete bc); - (* Update the value *) - V.Bottom) - else - (* Update the outer borrows before diving into the borrowed value *) - let outer = update_outer_borrows io outer (Borrow l') in - V.Borrow (super#visit_MutBorrow outer l' bv) - - method! visit_ALoan outer lc = - (* Note that the children avalues are just other, independent loans, - * so we don't need to update the outer borrows when diving in. - * We keep track of the parents/children relationship only because we - * need it to properly instantiate the backward functions when generating - * the pure translation. *) - match lc with - | V.AMutLoan (bid, av) -> - (* Nothing special to do *) - V.ALoan (super#visit_AMutLoan outer bid av) - | V.ASharedLoan (bids, v, av) -> - (* Explore the shared value - we need to update the outer borrows *) - let souter = update_outer_borrows io outer (Borrows bids) in - let v = super#visit_typed_value souter v in - (* Explore the child avalue - we keep the same outer borrows *) - let av = super#visit_typed_avalue outer av in - (* Reconstruct *) - V.ALoan (V.ASharedLoan (bids, v, av)) - | V.AEndedMutLoan { given_back; child } -> - (* The loan has ended, so no need to update the outer borrows *) - V.ALoan (super#visit_AEndedMutLoan outer given_back child) - | V.AEndedSharedLoan (v, av) -> - (* The loan has ended, so no need to update the outer borrows *) - V.ALoan (super#visit_AEndedSharedLoan outer v av) - | V.AIgnoredMutLoan (bid, av) -> - (* Nothing special to do *) - V.ALoan (super#visit_AIgnoredMutLoan outer bid av) - | V.AEndedIgnoredMutLoan { given_back; child } -> - (* Nothing special to do *) - V.ALoan (super#visit_AEndedIgnoredMutLoan outer given_back child) - | V.AIgnoredSharedLoan av -> - (* Nothing special to do *) - V.ALoan (super#visit_AIgnoredSharedLoan outer av) - (** We reimplement [visit_ALoan] because we may have to update the - outer borrows *) - - method! visit_ABorrow outer bc = - match bc with - | V.AMutBorrow (bid, av) -> - (* Check if this is the borrow we are looking for *) - if bid = l then ( - (* When ending a mut borrow, there are two cases: - * - in the general case, we have to end the whole abstraction - * (and thus raise an exception to signal that to the caller) - * - in some situations, the associated loan is inside the same - * abstraction as the borrow. In this situation, we can end - * the borrow without ending the whole abstraction, and we - * simply move the child avalue around. - *) - (* Check there are outer borrows, or if we need to end the whole - * abstraction *) - raise_if_outer outer; - (* Register the update *) - set_replaced_bc (Abstract bc); - (* Update the value - note that we are necessarily in the second - * of the two cases described above *) - V.ABottom) - else - (* Update the outer borrows before diving into the child avalue *) - let outer = update_outer_borrows io outer (Borrow bid) in - V.ABorrow (super#visit_AMutBorrow outer bid av) - | V.ASharedBorrow bid -> - (* Check if this is the borrow we are looking for *) - if bid = l then ( - (* Check there are outer borrows, or if we need to end the whole - * abstraction *) - raise_if_outer outer; - (* Register the update *) - set_replaced_bc (Abstract bc); - (* Update the value - note that we are necessarily in the second - * of the two cases described above *) - V.ABottom) - else V.ABorrow (super#visit_ASharedBorrow outer bid) - | V.AIgnoredMutBorrow av -> - (* Nothing special to do *) - V.ABorrow (super#visit_AIgnoredMutBorrow outer av) - | V.AProjSharedBorrow asb -> - (* Check if the borrow we are looking for is in the asb *) - if borrow_in_asb l asb then ( - (* Check there are outer borrows, or if we need to end the whole - * abstraction *) - raise_if_outer outer; - (* Register the update *) - set_replaced_bc (Abstract bc); - (* Update the value - note that we are necessarily in the second - * of the two cases described above *) - let asb = remove_borrow_from_asb l asb in - V.ABorrow (V.AProjSharedBorrow asb)) - else - (* Nothing special to do *) - V.ABorrow (super#visit_AProjSharedBorrow outer asb) - - method! visit_abs outer abs = - (* Update the outer abs *) - let outer_abs, outer_borrows = outer in - assert (Option.is_none outer_abs); - assert (Option.is_none outer_borrows); - let outer = (Some abs.V.abs_id, None) in - super#visit_abs outer abs - end - in - (* Catch the exceptions - raised if there are outer borrows *) - try - let ctx = obj#visit_eval_ctx (None, None) ctx in - Ok (ctx, !replaced_bc) - with FoundOuter outers -> Error outers - -(** Auxiliary function to end borrows. See [give_back]. - - When we end a mutable borrow, we need to "give back" the value it contained - to its original owner by reinserting it at the proper position. - - Note that this function checks that there is exactly one loan to which we - give the value back. - TODO: this was not the case before, so some sanity checks are not useful anymore. - *) -let give_back_value (config : C.config) (bid : V.BorrowId.id) - (nv : V.typed_value) (ctx : C.eval_ctx) : C.eval_ctx = - (* We use a reference to check that we updated exactly one loan *) - let replaced : bool ref = ref false in - let set_replaced () = - assert (not !replaced); - replaced := true - in - (* Whenever giving back symbolic values, they shouldn't contain already ended regions *) - let check_symbolic_no_ended = true in - (* We sometimes need to reborrow values while giving a value back due: prepare that *) - let allow_reborrows = true in - let fresh_reborrow, apply_registered_reborrows = - prepare_reborrows config allow_reborrows ctx - in - (* The visitor to give back the values *) - let obj = - object (self) - inherit [_] C.map_eval_ctx as super - - method! visit_Loan opt_abs lc = - match lc with - | V.SharedLoan (bids, v) -> - (* We are giving back a value (i.e., the content of a *mutable* - * borrow): nothing special to do *) - V.Loan (super#visit_SharedLoan opt_abs bids v) - | V.MutLoan bid' -> - (* Check if this is the loan we are looking for *) - if bid' = bid then ( - set_replaced (); - nv.V.value) - else V.Loan (super#visit_MutLoan opt_abs bid') - - method! visit_typed_avalue opt_abs (av : V.typed_avalue) : V.typed_avalue - = - match av.V.value with - | V.ALoan lc -> - let value = self#visit_typed_ALoan opt_abs av.V.ty lc in - ({ av with V.value } : V.typed_avalue) - | _ -> super#visit_typed_avalue opt_abs av - (** This is a bit annoying, but as we need the type of the avalue we - are exploring, in order to be able to project the value we give - back, we need to reimplement [visit_typed_avalue] instead of - [visit_ALoan] *) - - method visit_typed_ALoan (opt_abs : V.abs option) (ty : T.rty) - (lc : V.aloan_content) : V.avalue = - (* Preparing a bit *) - let regions = - match opt_abs with - | None -> failwith "Unreachable" - | Some abs -> abs.V.regions - in - match lc with - | V.AMutLoan (bid', child) -> - if bid' = bid then ( - (* This is the loan we are looking for: apply the projection to - * the value we give back and replaced this mutable loan with - * an ended loan *) - (* Register the insertion *) - set_replaced (); - (* Apply the projection *) - let given_back = - apply_proj_borrows check_symbolic_no_ended ctx fresh_reborrow - regions nv ty - in - (* Return the new value *) - V.ALoan (V.AEndedMutLoan { given_back; child })) - else - (* Continue exploring *) - V.ALoan (super#visit_AMutLoan opt_abs bid' child) - | V.ASharedLoan (bids, v, av) -> - (* We are giving back a value to a *mutable* loan: nothing special to do *) - V.ALoan (super#visit_ASharedLoan opt_abs bids v av) - | V.AEndedMutLoan { given_back; child } -> - (* Nothing special to do *) - V.ALoan (super#visit_AEndedMutLoan opt_abs given_back child) - | V.AEndedSharedLoan (v, av) -> - (* Nothing special to do *) - V.ALoan (super#visit_AEndedSharedLoan opt_abs v av) - | V.AIgnoredMutLoan (bid', child) -> - (* This loan is ignored, but we may have to project on a subvalue - * of the value which is given back *) - if bid' = bid then - (* Note that we replace the ignored mut loan by an *ended* ignored - * mut loan. Also, this is not the loan we are looking for *per se*: - * we don't register the fact that we inserted the value somewhere - * (i.e., we don't call [set_replaced]) *) - let given_back = - apply_proj_borrows check_symbolic_no_ended ctx fresh_reborrow - regions nv ty - in - V.ALoan (V.AEndedIgnoredMutLoan { given_back; child }) - else V.ALoan (super#visit_AIgnoredMutLoan opt_abs bid' child) - | V.AEndedIgnoredMutLoan { given_back; child } -> - (* Nothing special to do *) - V.ALoan (super#visit_AEndedIgnoredMutLoan opt_abs given_back child) - | V.AIgnoredSharedLoan av -> - (* Nothing special to do *) - V.ALoan (super#visit_AIgnoredSharedLoan opt_abs av) - (** We are not specializing an already existing method, but adding a - new method (for projections, we need type information) *) - - method! visit_Abs opt_abs abs = - (* We remember in which abstraction we are before diving - - * this is necessary for projecting values: we need to know - * over which regions to project *) - assert (Option.is_none opt_abs); - super#visit_Abs (Some abs) abs - end - in - - (* Explore the environment *) - let ctx = obj#visit_eval_ctx None ctx in - (* Check we gave back to exactly one loan *) - assert !replaced; - (* Apply the reborrows *) - apply_registered_reborrows ctx - -(** Auxiliary function to end borrows. See [give_back]. - - This function is similar to [give_back_value] but gives back an [avalue] - (coming from an abstraction). - - It is used when ending a borrow inside an abstraction, when the corresponding - loan is inside the same abstraction (in which case we don't need to end the whole - abstraction). - - REMARK: this function can't be used to give back the values borrowed by - end abstraction when ending this abstraction. When doing this, we need - to convert the [avalue] to a [value] by introducing the proper symbolic values. - *) -let give_back_avalue (_config : C.config) (bid : V.BorrowId.id) - (nv : V.typed_avalue) (ctx : C.eval_ctx) : C.eval_ctx = - (* We use a reference to check that we updated exactly one loan *) - let replaced : bool ref = ref false in - let set_replaced () = - assert (not !replaced); - replaced := true - in - let obj = - object (self) - inherit [_] C.map_eval_ctx as super - - method! visit_typed_avalue opt_abs (av : V.typed_avalue) : V.typed_avalue - = - match av.V.value with - | V.ALoan lc -> - let value = self#visit_typed_ALoan opt_abs av.V.ty lc in - ({ av with V.value } : V.typed_avalue) - | _ -> super#visit_typed_avalue opt_abs av - (** This is a bit annoying, but as we need the type of the avalue we - are exploring, in order to be able to project the value we give - back, we need to reimplement [visit_typed_avalue] instead of - [visit_ALoan] *) - - method visit_typed_ALoan (opt_abs : V.abs option) (ty : T.rty) - (lc : V.aloan_content) : V.avalue = - match lc with - | V.AMutLoan (bid', child) -> - if bid' = bid then ( - (* This is the loan we are looking for: apply the projection to - * the value we give back and replaced this mutable loan with - * an ended loan *) - (* Register the insertion *) - set_replaced (); - (* Sanity check *) - assert (nv.V.ty = ty); - (* Return the new value *) - V.ALoan (V.AEndedMutLoan { given_back = nv; child })) - else - (* Continue exploring *) - V.ALoan (super#visit_AMutLoan opt_abs bid' child) - | V.ASharedLoan (bids, v, av) -> - (* We are giving back a value to a *mutable* loan: nothing special to do *) - V.ALoan (super#visit_ASharedLoan opt_abs bids v av) - | V.AEndedMutLoan { given_back; child } -> - (* Nothing special to do *) - V.ALoan (super#visit_AEndedMutLoan opt_abs given_back child) - | V.AEndedSharedLoan (v, av) -> - (* Nothing special to do *) - V.ALoan (super#visit_AEndedSharedLoan opt_abs v av) - | V.AIgnoredMutLoan (bid', child) -> - (* This loan is ignored, but we may have to project on a subvalue - * of the value which is given back *) - if bid' = bid then ( - (* Note that we replace the ignored mut loan by an *ended* ignored - * mut loan. Also, this is not the loan we are looking for *per se*: - * we don't register the fact that we inserted the value somewhere - * (i.e., we don't call [set_replaced]) *) - (* Sanity check *) - assert (nv.V.ty = ty); - V.ALoan (V.AEndedIgnoredMutLoan { given_back = nv; child })) - else V.ALoan (super#visit_AIgnoredMutLoan opt_abs bid' child) - | V.AEndedIgnoredMutLoan { given_back; child } -> - (* Nothing special to do *) - V.ALoan (super#visit_AEndedIgnoredMutLoan opt_abs given_back child) - | V.AIgnoredSharedLoan av -> - (* Nothing special to do *) - V.ALoan (super#visit_AIgnoredSharedLoan opt_abs av) - (** We are not specializing an already existing method, but adding a - new method (for projections, we need type information) *) - end - in - - (* Explore the environment *) - let ctx = obj#visit_eval_ctx None ctx in - (* Check we gave back to exactly one loan *) - assert !replaced; - (* Return *) - ctx - -(** Auxiliary function to end borrows. See [give_back]. - - When we end a shared borrow, we need to remove the borrow id from the list - of borrows to the shared value. - - Note that this function checks that there is exactly one shared loan that - we update. - TODO: this was not the case before, so some sanity checks are not useful anymore. - *) -let give_back_shared _config (bid : V.BorrowId.id) (ctx : C.eval_ctx) : - C.eval_ctx = - (* We use a reference to check that we updated exactly one loan *) - let replaced : bool ref = ref false in - let set_replaced () = - assert (not !replaced); - replaced := true - in - let obj = - object - inherit [_] C.map_eval_ctx as super - - method! visit_Loan opt_abs lc = - match lc with - | V.SharedLoan (bids, shared_value) -> - if V.BorrowId.Set.mem bid bids then ( - (* This is the loan we are looking for *) - set_replaced (); - (* If there remains exactly one borrow identifier, we need - * to end the loan. Otherwise, we just remove the current - * loan identifier *) - if V.BorrowId.Set.cardinal bids = 1 then shared_value.V.value - else - V.Loan - (V.SharedLoan (V.BorrowId.Set.remove bid bids, shared_value))) - else - (* Not the loan we are looking for: continue exploring *) - V.Loan (super#visit_SharedLoan opt_abs bids shared_value) - | V.MutLoan bid' -> - (* We are giving back a *shared* borrow: nothing special to do *) - V.Loan (super#visit_MutLoan opt_abs bid') - - method! visit_ALoan opt_abs lc = - match lc with - | V.AMutLoan (bid, av) -> - (* Nothing special to do (we are giving back a *shared* borrow) *) - V.ALoan (super#visit_AMutLoan opt_abs bid av) - | V.ASharedLoan (bids, shared_value, child) -> - if V.BorrowId.Set.mem bid bids then ( - (* This is the loan we are looking for *) - set_replaced (); - (* If there remains exactly one borrow identifier, we need - * to end the loan. Otherwise, we just remove the current - * loan identifier *) - if V.BorrowId.Set.cardinal bids = 1 then - V.ALoan (V.AEndedSharedLoan (shared_value, child)) - else - V.ALoan - (V.ASharedLoan - (V.BorrowId.Set.remove bid bids, shared_value, child))) - else - (* Not the loan we are looking for: continue exploring *) - V.ALoan (super#visit_ASharedLoan opt_abs bids shared_value child) - | V.AEndedMutLoan { given_back; child } -> - (* Nothing special to do (the loan has ended) *) - V.ALoan (super#visit_AEndedMutLoan opt_abs given_back child) - | V.AEndedSharedLoan (v, av) -> - (* Nothing special to do (the loan has ended) *) - V.ALoan (super#visit_AEndedSharedLoan opt_abs v av) - | V.AIgnoredMutLoan (bid, av) -> - (* Nothing special to do (we are giving back a *shared* borrow) *) - V.ALoan (super#visit_AIgnoredMutLoan opt_abs bid av) - | V.AEndedIgnoredMutLoan { given_back; child } -> - (* Nothing special to do *) - V.ALoan (super#visit_AEndedIgnoredMutLoan opt_abs given_back child) - | V.AIgnoredSharedLoan av -> - (* Nothing special to do *) - V.ALoan (super#visit_AIgnoredSharedLoan opt_abs av) - end - in - - (* Explore the environment *) - let ctx = obj#visit_eval_ctx None ctx in - (* Check we gave back to exactly one loan *) - assert !replaced; - (* Return *) - ctx - -(** When copying values, we duplicate the shared borrows. This is tantamount - to reborrowing the shared value. The following function applies this change - to an environment by inserting a new borrow id in the set of borrows tracked - by a shared value, referenced by the [original_bid] argument. - *) -let reborrow_shared (original_bid : V.BorrowId.id) (new_bid : V.BorrowId.id) - (ctx : C.eval_ctx) : C.eval_ctx = - (* Keep track of changes *) - let r = ref false in - let set_ref () = - assert (not !r); - r := true - in - - let obj = - object - inherit [_] C.map_env as super - - method! visit_SharedLoan env bids sv = - (* Shared loan: check if the borrow id we are looking for is in the - set of borrow ids. If yes, insert the new borrow id, otherwise - explore inside the shared value *) - if V.BorrowId.Set.mem original_bid bids then ( - set_ref (); - let bids' = V.BorrowId.Set.add new_bid bids in - V.SharedLoan (bids', sv)) - else super#visit_SharedLoan env bids sv - - method! visit_ASharedLoan env bids v av = - (* This case is similar to the [SharedLoan] case *) - if V.BorrowId.Set.mem original_bid bids then ( - set_ref (); - let bids' = V.BorrowId.Set.add new_bid bids in - V.ASharedLoan (bids', v, av)) - else super#visit_ASharedLoan env bids v av - end - in - - let env = obj#visit_env () ctx.env in - (* Check that we reborrowed once *) - assert !r; - { ctx with env } - -(** Auxiliary function: see [end_borrow_in_env] *) -let give_back (config : C.config) (l : V.BorrowId.id) (bc : g_borrow_content) - (ctx : C.eval_ctx) : C.eval_ctx = - (* This is used for sanity checks *) - let sanity_ek = - { enter_shared_loans = true; enter_mut_borrows = true; enter_abs = true } - in - match bc with - | Concrete (V.MutBorrow (l', tv)) -> - (* Sanity check *) - assert (l' = l); - (* Check that the corresponding loan is somewhere - purely a sanity check *) - assert (Option.is_some (lookup_loan_opt sanity_ek l ctx)); - (* Update the context *) - give_back_value config l tv ctx - | Concrete (V.SharedBorrow l' | V.InactivatedMutBorrow l') -> - (* Sanity check *) - assert (l' = l); - (* Check that the borrow is somewhere - purely a sanity check *) - assert (Option.is_some (lookup_loan_opt sanity_ek l ctx)); - (* Update the context *) - give_back_shared config l ctx - | Abstract (V.AMutBorrow (l', av)) -> - (* Sanity check *) - assert (l' = l); - (* Check that the corresponding loan is somewhere - purely a sanity check *) - assert (Option.is_some (lookup_loan_opt sanity_ek l ctx)); - (* Update the context *) - give_back_avalue config l av ctx - | Abstract (V.ASharedBorrow l') -> - (* Sanity check *) - assert (l' = l); - (* Check that the borrow is somewhere - purely a sanity check *) - assert (Option.is_some (lookup_loan_opt sanity_ek l ctx)); - (* Update the context *) - give_back_shared config l ctx - | Abstract (V.AProjSharedBorrow asb) -> - (* Sanity check *) - assert (borrow_in_asb l asb); - (* Update the context *) - give_back_shared config l ctx - | Abstract (V.AIgnoredMutBorrow _) -> failwith "Unreachable" - -(** Convert an [avalue] to a [value]. - - This function is used when ending abstractions: whenever we end a borrow - in an abstraction, we converted the borrowed [avalue] to a fresh symbolic - [value], then give back this [value] to the context. - - Note that some regions may have ended in the symbolic value we generate. - For instance, consider the following function signature: - ``` - fn f<'a>(x : &'a mut &'a mut u32); - ``` - When ending the abstraction, the value given back for the outer borrow - should be ⊥. In practice, we will give back a symbolic value which can't - be expanded (because expanding this symbolic value would require expanding - a reference whose region has already ended). - *) -let convert_avalue_to_value (av : V.typed_avalue) (ctx : C.eval_ctx) : - C.eval_ctx * V.typed_value = - (* Convert the type *) - let ty = Subst.erase_regions av.V.ty in - (* Generate the fresh a symbolic value *) - let ctx, sv_id = C.fresh_symbolic_value_id ctx in - let svalue : V.symbolic_value = { V.sv_id; sv_ty = av.V.ty } in - let value : V.symbolic_proj_comp = - (* Note that the set of ended regions is empty: we shouldn't have to take - * into account any ended regions at this point, otherwise we would be in - * the first case where we should return ⊥ *) - { V.svalue; V.rset_ended = T.RegionId.Set.empty } - in - let value = V.Symbolic value in - (ctx, { V.value; V.ty }) - -(** End a borrow identified by its borrow id in a context - - First lookup the borrow in the context and replace it with [Bottom]. - Then, check that there is an associated loan in the context. When moving - values, before putting the value in its destination, we get an - intermediate state where some values are "outside" the context and thus - inaccessible. As [give_back_value] just performs a map for instance (TODO: - not the case anymore), we need to check independently that there is indeed a - loan ready to receive the value we give back (note that we also have other - invariants like: there is exacly one mutable loan associated to a mutable - borrow, etc. but they are more easily maintained). - Note that in theory, we shouldn't never reach a problematic state as the - one we describe above, because when we move a value we need to end all the - loans inside before moving it. Still, it is a very useful sanity check. - Finally, give the values back. - - Of course, we end outer borrows before updating the target borrow if it - proves necessary: this is controled by the [io] parameter. If it is [Inner], - we allow ending inner borrows (without ending the outer borrows first), - otherwise we only allow ending outer borrows. - If a borrow is inside an abstraction, we need to end the whole abstraction, - at the exception of the case where the loan corresponding to the borrow is - inside the same abstraction. We control this with the [allowed_abs] parameter: - if it is not `None`, we allow ending a borrow if it is inside the given - abstraction. In practice, if the value is `Some abs_id`, we should have - checked that the corresponding loan is inside the abstraction given by - `abs_id` before. In practice, only [end_borrow] should call itself - with `allowed_abs = Some ...`, all the other calls should use `allowed_abs = None`: - if you look ath the implementation details, `end_borrow` performs - all tne necessary checks in case a borrow is inside an abstraction. - *) -let rec end_borrow (config : C.config) (io : inner_outer) - (allowed_abs : V.AbstractionId.id option) (l : V.BorrowId.id) - (ctx : C.eval_ctx) : C.eval_ctx = - match end_borrow_get_borrow io allowed_abs l ctx with - (* Two cases: - * - error: we found outer borrows (end them first) - * - success: we didn't find outer borrows when updating (but maybe we actually - didn't find the borrow we were looking for...) - *) - | Error outer -> ( - (* End the outer borrows, abstraction, then try again to end the target - * borrow (if necessary) *) - match outer with - | OuterBorrows (Borrows bids) -> - (* Note that when ending outer borrows, we use io=Outer. However, - * we shouldn't need to end outer borrows if io=Inner, so we just - * add the following assertion *) - assert (io = Outer); - (* Note that we might get there with `allowed_abs <> None`: we might - * be trying to end a borrow inside an abstraction, but which is actually - * inside another borrow *) - let allowed_abs' = None in - let ctx = end_borrows config io allowed_abs' bids ctx in - (* Retry to end the borrow *) - end_borrow config io allowed_abs l ctx - | OuterBorrows (Borrow bid) -> - (* See the comments for the previous case *) - assert (io = Outer); - let allowed_abs' = None in - let ctx = end_borrow config io allowed_abs' bid ctx in - (* Retry to end the borrow *) - end_borrow config io allowed_abs l ctx - | OuterAbs abs_id -> ( - (* The borrow is inside an asbtraction: check if the corresponding - * loan is inside the same abstraction. If this is the case, we end - * the borrow without ending the abstraction. If not, we need to - * end the whole abstraction *) - (* Note that we can lookup the loan anywhere *) - let ek = - { - enter_shared_loans = true; - enter_mut_borrows = true; - enter_abs = true; - } - in - match lookup_loan ek l ctx with - | AbsId loan_abs_id, _ -> - if loan_abs_id = abs_id then ( - (* Same abstraction! We can end the borrow *) - let ctx = end_borrow config io (Some abs_id) l ctx in - (* Sanity check *) - assert (Option.is_none (lookup_borrow_opt ek l ctx)); - ctx) - else - (* Not the same abstraction: we need to end the whole abstraction. - * By doing that we should have ended the target borrow (see the - * below sanity check) *) - let ctx = end_abstraction config abs_id ctx in - (* Sanity check: we ended the target borrow *) - assert (Option.is_none (lookup_borrow_opt ek l ctx)); - ctx - | VarId _, _ -> - (* The loan is not inside the same abstraction (actually inside - * a non-abstraction value): we need to end the whole abstraction *) - let ctx = end_abstraction config abs_id ctx in - (* Sanity check: we ended the target borrow *) - assert (Option.is_none (lookup_borrow_opt ek l ctx)); - ctx)) - | Ok (ctx, None) -> - (* It is possible that we can't find a borrow in symbolic mode (ending - * an abstraction may end several borrows at once *) - assert (config.mode = SymbolicMode); - ctx - (* We found a borrow: give the value back (i.e., update the corresponding loan) *) - | Ok (ctx, Some bc) -> give_back config l bc ctx - -and end_borrows (config : C.config) (io : inner_outer) - (allowed_abs : V.AbstractionId.id option) (lset : V.BorrowId.Set.t) - (ctx : C.eval_ctx) : C.eval_ctx = - V.BorrowId.Set.fold - (fun id ctx -> end_borrow config io allowed_abs id ctx) - lset ctx - -and end_abstraction (config : C.config) (abs_id : V.AbstractionId.id) - (ctx : C.eval_ctx) : C.eval_ctx = - (* Lookup the abstraction *) - let abs = C.ctx_lookup_abs ctx abs_id in - (* End the parent abstractions first *) - let ctx = end_abstractions config abs.parents ctx in - (* End the loans inside the abstraction *) - let ctx = end_abstraction_loans config abs_id ctx in - (* End the abstraction itself by redistributing the borrows it contains *) - let ctx = end_abstraction_borrows config abs_id ctx in - (* End the regions owned by the abstraction *) - let ctx = end_abstraction_regions config abs_id ctx in - (* Remove all the references to the id of the current abstraction, and remove - * the abstraction itself *) - end_abstraction_remove_from_context config abs_id ctx - -and end_abstractions (config : C.config) (abs_ids : V.AbstractionId.set_t) - (ctx : C.eval_ctx) : C.eval_ctx = - V.AbstractionId.Set.fold - (fun id ctx -> end_abstraction config id ctx) - abs_ids ctx - -and end_abstraction_loans (config : C.config) (abs_id : V.AbstractionId.id) - (ctx : C.eval_ctx) : C.eval_ctx = - (* Lookup the abstraction *) - let abs = C.ctx_lookup_abs ctx abs_id in - (* End the first loan we find *) - let obj = - object - inherit [_] V.iter_abs as super - - method! visit_aloan_content env lc = - match lc with - | V.AMutLoan (bid, _) -> raise (FoundBorrowIds (Borrow bid)) - | V.ASharedLoan (bids, _, _) -> raise (FoundBorrowIds (Borrows bids)) - | V.AEndedMutLoan { given_back; child } -> - super#visit_AEndedMutLoan env given_back child - | V.AEndedSharedLoan (v, av) -> super#visit_AEndedSharedLoan env v av - | V.AIgnoredMutLoan (bid, av) -> - (* Note that this loan can't come from a parent abstraction, because - * we should have ended them already) *) - super#visit_AIgnoredMutLoan env bid av - | V.AEndedIgnoredMutLoan { given_back; child } -> - super#visit_AEndedIgnoredMutLoan env given_back child - | V.AIgnoredSharedLoan av -> super#visit_AIgnoredSharedLoan env av - end - in - try - (* Check if there are loans *) - obj#visit_abs () abs; - (* No loans: nothing to update *) - ctx - with (* There are loans: end them, then recheck *) - | FoundBorrowIds bids -> - let ctx = - match bids with - | Borrow bid -> end_outer_borrow config bid ctx - | Borrows bids -> end_outer_borrows config bids ctx - in - (* Recheck *) - end_abstraction_loans config abs_id ctx - -and end_abstraction_borrows (config : C.config) (abs_id : V.AbstractionId.id) - (ctx : C.eval_ctx) : C.eval_ctx = - (* Note that the abstraction mustn't contain any loans *) - (* We end the borrows, starting with the *inner* ones. This is important - when considering nested borrows which have the same lifetime. - - For instance: - ``` - x -> mut_loan l1 - px -> mut_loan l0 - abs0 { a_mut_borrow l0 (a_mut_borrow l1 (U32 3)) } - ``` - - becomes (`U32 3` doesn't contain ⊥, so we give back a symbolic value): - ``` - x -> @s0 - px -> mut_loan l0 - abs0 { a_mut_borrow l0 ⊥ } - ``` - - then (the borrowed value contains ⊥, we give back ⊥): - ``` - x -> @s0 - px -> ⊥ - abs0 { ⊥ } - ``` - *) - (* We explore in-depth and use exceptions. When exploring a borrow, if - * the exploration didn't trigger an exception, it means there are no - * inner borrows to end: we can thus trigger an exception for the current - * borrow. *) - let obj = - object - inherit [_] V.iter_abs as super - - method! visit_aborrow_content env bc = - (* In-depth exploration *) - super#visit_aborrow_content env bc; - (* No exception was raise: we can raise an exception for the - * current borrow *) - match bc with - | V.AMutBorrow (_, _) | V.ASharedBorrow _ -> - (* Raise an exception *) - raise (FoundABorrowContent bc) - | V.AProjSharedBorrow asb -> - (* Raise an exception only if the asb contains borrows *) - if - List.exists - (fun x -> match x with V.AsbBorrow _ -> true | _ -> false) - asb - then raise (FoundABorrowContent bc) - else () - | V.AIgnoredMutBorrow _ -> - (* Nothing to do for ignored borrows *) - () - end - in - (* Lookup the abstraction *) - let abs = C.ctx_lookup_abs ctx abs_id in - try - (* Explore the abstraction, looking for borrows *) - obj#visit_abs () abs; - (* No borrows: nothing to update *) - ctx - with - (* There are borrows: end them, then reexplore *) - | FoundABorrowContent bc -> - (* First, replace the borrow by ⊥ *) - let bid = - match bc with - | V.AMutBorrow (bid, _) | V.ASharedBorrow bid -> bid - | V.AProjSharedBorrow asb -> ( - (* There should be at least one borrow identifier in the set, which we - * can use to identify the whole set *) - match - List.find - (fun x -> match x with V.AsbBorrow _ -> true | _ -> false) - asb - with - | V.AsbBorrow bid -> bid - | _ -> failwith "Unexpected") - | V.AIgnoredMutBorrow _ -> failwith "Unexpected" - in - let ctx = update_aborrow ek_all bid V.ABottom ctx in - (* Then give back the value *) - let ctx = - match bc with - | V.AMutBorrow (bid, av) -> - (* First, convert the avalue to a (fresh symbolic) value *) - let ctx, v = convert_avalue_to_value av ctx in - give_back_value config bid v ctx - | V.ASharedBorrow bid -> give_back_shared config bid ctx - | V.AProjSharedBorrow _ -> - (* Nothing to do *) - ctx - | V.AIgnoredMutBorrow _ -> failwith "Unexpected" - in - (* Reexplore *) - end_abstraction_borrows config abs_id ctx - -(** Update the symbolic values in a context to register the regions in the - abstraction we are ending as already ended. - Note that this function also checks that no symbolic value in an abstraction - contains regions which we are ending. - Of course, we ignore the abstraction we are currently ending... - *) -and end_abstraction_regions (_config : C.config) (abs_id : V.AbstractionId.id) - (ctx : C.eval_ctx) : C.eval_ctx = - (* Lookup the abstraction to retrieve the set of owned regions *) - let abs = C.ctx_lookup_abs ctx abs_id in - let ended_regions = abs.V.regions in - (* Update all the symbolic values in the context *) - let obj = - object - inherit [_] C.map_eval_ctx as super - - method! visit_Symbolic _ sproj = - let sproj = - { - sproj with - V.rset_ended = T.RegionId.Set.union sproj.V.rset_ended ended_regions; - } - in - V.Symbolic sproj - - method! visit_aproj (abs_regions : T.RegionId.set_t option) aproj = - (* Sanity check *) - (match aproj with - | V.AProjLoans _ -> () - | V.AProjBorrows (sv, ty) -> ( - match abs_regions with - | None -> failwith "Unexpected" - | Some abs_regions -> - assert ( - not - (projections_intersect sv.V.sv_ty ended_regions ty - abs_regions)))); - (* Return - nothing to update *) - aproj - - method! visit_abs (regions : T.RegionId.set_t option) abs = - if abs.V.abs_id = abs_id then abs - else ( - assert (Option.is_none regions); - (* Check that we don't project over already ended regions *) - assert (T.RegionId.Set.disjoint ended_regions abs.V.regions); - (* Remember the set of regions owned by the abstraction *) - let regions = Some abs.V.regions in - super#visit_abs regions abs) - (** Whenever we dive in an abstraction, we need to keep track of the - set of regions owned by the abstraction. - Also: we don't dive in the abstraction we are currently ending... *) - end - in - (* Update the context *) - obj#visit_eval_ctx None ctx - -(** Remove an abstraction from the context, as well as all its references *) -and end_abstraction_remove_from_context (_config : C.config) - (abs_id : V.AbstractionId.id) (ctx : C.eval_ctx) : C.eval_ctx = - let map_env_elem (ev : C.env_elem) : C.env_elem option = - match ev with - | C.Var (_, _) | C.Frame -> Some ev - | C.Abs abs -> - if abs.abs_id = abs_id then None - else - let parents = V.AbstractionId.Set.remove abs_id abs.parents in - Some (C.Abs { abs with V.parents }) - in - let env = List.filter_map map_env_elem ctx.C.env in - { ctx with C.env } - -and end_outer_borrow config = end_borrow config Outer None - -and end_outer_borrows config = end_borrows config Outer None - -and end_inner_borrow config = end_borrow config Inner None - -and end_inner_borrows config = end_borrows config Inner None - -(** Helper function: see [activate_inactivated_mut_borrow]. - - This function updates the shared loan to a mutable loan (we then update - the borrow with another helper). Of course, the shared loan must contain - exactly one borrow id (the one we give as parameter), otherwise we can't - promote it. Also, the shared value mustn't contain any loan. - - The returned value (previously shared) is checked: - - it mustn't contain loans - - it mustn't contain [Bottom] - - it mustn't contain inactivated borrows - TODO: this kind of checks should be put in an auxiliary helper, because - they are redundant - *) -let promote_shared_loan_to_mut_loan (l : V.BorrowId.id) (ctx : C.eval_ctx) : - C.eval_ctx * V.typed_value = - (* Lookup the shared loan *) - let ek = - { enter_shared_loans = false; enter_mut_borrows = true; enter_abs = false } - in - match lookup_loan ek l ctx with - | _, Concrete (V.MutLoan _) -> - failwith "Expected a shared loan, found a mut loan" - | _, Concrete (V.SharedLoan (bids, sv)) -> - (* Check that there is only one borrow id (l) and update the loan *) - assert (V.BorrowId.Set.mem l bids && V.BorrowId.Set.cardinal bids = 1); - (* We need to check that there aren't any loans in the value: - we should have gotten rid of those already, but it is better - to do a sanity check. *) - assert (not (loans_in_value sv)); - (* Check there isn't [Bottom] (this is actually an invariant *) - assert (not (bottom_in_value sv)); - (* Check there aren't inactivated borrows *) - assert (not (inactivated_in_value sv)); - (* Update the loan content *) - let ctx = update_loan ek l (V.MutLoan l) ctx in - (* Return *) - (ctx, sv) - | _, Abstract _ -> - (* I don't think it is possible to have two-phase borrows involving borrows - * returned by abstractions. I'm not sure how we could handle that anyway. *) - failwith - "Can't promote a shared loan to a mutable loan if the loan is inside \ - an abstraction" - -(** Helper function: see [activate_inactivated_mut_borrow]. - - This function updates a shared borrow to a mutable borrow. - *) -let promote_inactivated_borrow_to_mut_borrow (l : V.BorrowId.id) - (borrowed_value : V.typed_value) (ctx : C.eval_ctx) : C.eval_ctx = - (* Lookup the inactivated borrow - note that we don't go inside borrows/loans: - there can't be inactivated borrows inside other borrows/loans - *) - let ek = - { enter_shared_loans = false; enter_mut_borrows = false; enter_abs = false } - in - match lookup_borrow ek l ctx with - | Concrete (V.SharedBorrow _ | V.MutBorrow (_, _)) -> - failwith "Expected an inactivated mutable borrow" - | Concrete (V.InactivatedMutBorrow _) -> - (* Update it *) - update_borrow ek l (V.MutBorrow (l, borrowed_value)) ctx - | Abstract _ -> - (* This can't happen for sure *) - failwith - "Can't promote a shared borrow to a mutable borrow if the borrow is \ - inside an abstraction" - -(** Promote an inactivated mut borrow to a mut borrow. - - The borrow must point to a shared value which is borrowed exactly once. - *) -let rec activate_inactivated_mut_borrow (config : C.config) (io : inner_outer) - (l : V.BorrowId.id) (ctx : C.eval_ctx) : C.eval_ctx = - (* Lookup the value *) - let ek = - { enter_shared_loans = false; enter_mut_borrows = true; enter_abs = false } - in - match lookup_loan ek l ctx with - | _, Concrete (V.MutLoan _) -> failwith "Unreachable" - | _, Concrete (V.SharedLoan (bids, sv)) -> ( - (* If there are loans inside the value, end them. Note that there can't be - inactivated borrows inside the value. - If we perform an update, do a recursive call to lookup the updated value *) - match get_first_loan_in_value sv with - | Some lc -> - (* End the loans *) - let ctx = - match lc with - | V.SharedLoan (bids, _) -> end_outer_borrows config bids ctx - | V.MutLoan bid -> end_outer_borrow config bid ctx - in - (* Recursive call *) - activate_inactivated_mut_borrow config io l ctx - | None -> - (* No loan to end inside the value *) - (* Some sanity checks *) - L.log#ldebug - (lazy - ("activate_inactivated_mut_borrow: resulting value:\n" - ^ V.show_typed_value sv)); - assert (not (loans_in_value sv)); - assert (not (bottom_in_value sv)); - assert (not (inactivated_in_value sv)); - (* End the borrows which borrow from the value, at the exception of - the borrow we want to promote *) - let bids = V.BorrowId.Set.remove l bids in - let allowed_abs = None in - let ctx = end_borrows config io allowed_abs bids ctx in - (* Promote the loan *) - let ctx, borrowed_value = promote_shared_loan_to_mut_loan l ctx in - (* Promote the borrow - the value should have been checked by - [promote_shared_loan_to_mut_loan] - *) - promote_inactivated_borrow_to_mut_borrow l borrowed_value ctx) - | _, Abstract _ -> - (* I don't think it is possible to have two-phase borrows involving borrows - * returned by abstractions. I'm not sure how we could handle that anyway. *) - failwith - "Can't activate an inactivated mutable borrow referencing a loan inside\n\ - \ an abstraction" - (** Paths *) (** When we fail reading from or writing to a path, it might be because we diff --git a/src/InterpreterBorrows.ml b/src/InterpreterBorrows.ml new file mode 100644 index 00000000..e8503d57 --- /dev/null +++ b/src/InterpreterBorrows.ml @@ -0,0 +1,1115 @@ +module T = Types +module V = Values +open Scalars +module E = Expressions +open Errors +module C = Contexts +module Subst = Substitute +module A = CfimAst +module L = Logging +open TypesUtils +open ValuesUtils +module Inv = Invariants +module S = Synthesis +open Utils +open InterpreterUtils +open InterpreterProjectors + +(** Auxiliary function to end borrows: lookup a borrow in the environment, + update it (by returning an updated environment where the borrow has been + replaced by [Bottom])) if we can end the borrow (for instance, it is not + an outer borrow...) or return the reason why we couldn't update the borrow. + + [end_borrow] then simply performs a loop: as long as we need to end (outer) + borrows, we end them, before finally ending the borrow we wanted to end in the + first place. + + Note that it is possible to end a borrow in an abstraction, without ending + the whole abstraction, if the corresponding loan is inside the abstraction + as well. The [allowed_abs] parameter controls whether we allow to end borrows + in an abstraction or not, and in which abstraction. +*) +let end_borrow_get_borrow (io : inner_outer) + (allowed_abs : V.AbstractionId.id option) (l : V.BorrowId.id) + (ctx : C.eval_ctx) : + (C.eval_ctx * g_borrow_content option, outer_borrows_or_abs) result = + (* We use a reference to communicate the kind of borrow we found, if we + * find one *) + let replaced_bc : g_borrow_content option ref = ref None in + let set_replaced_bc (bc : g_borrow_content) = + assert (Option.is_none !replaced_bc); + replaced_bc := Some bc + in + (* Raise an exception if there are outer borrows or if we are inside an + * abstraction: this exception is caught in a wrapper function *) + let raise_if_outer (outer : V.AbstractionId.id option * borrow_ids option) = + let outer_abs, outer_borrows = outer in + match outer_abs with + | Some abs -> ( + if + (* Check if we can end borrows inside this abstraction *) + Some abs <> allowed_abs + then raise (FoundOuter (OuterAbs abs)) + else + match outer_borrows with + | Some borrows -> raise (FoundOuter (OuterBorrows borrows)) + | None -> ()) + | None -> ( + match outer_borrows with + | Some borrows -> raise (FoundOuter (OuterBorrows borrows)) + | None -> ()) + in + + (* The environment is used to keep track of the outer loans *) + let obj = + object + inherit [_] C.map_eval_ctx as super + + method! visit_Loan (outer : V.AbstractionId.id option * borrow_ids option) + lc = + match lc with + | V.MutLoan bid -> V.Loan (super#visit_MutLoan outer bid) + | V.SharedLoan (bids, v) -> + (* Update the outer borrows before diving into the shared value *) + let outer = update_outer_borrows io outer (Borrows bids) in + V.Loan (super#visit_SharedLoan outer bids v) + (** We reimplement [visit_Loan] because we may have to update the + outer borrows *) + + method! visit_Borrow outer bc = + match bc with + | SharedBorrow l' | InactivatedMutBorrow l' -> + (* Check if this is the borrow we are looking for *) + if l = l' then ( + (* Check if there are outer borrows or if we are inside an abstraction *) + raise_if_outer outer; + (* Register the update *) + set_replaced_bc (Concrete bc); + (* Update the value *) + V.Bottom) + else super#visit_Borrow outer bc + | V.MutBorrow (l', bv) -> + (* Check if this is the borrow we are looking for *) + if l = l' then ( + (* Check if there are outer borrows or if we are inside an abstraction *) + raise_if_outer outer; + (* Register the update *) + set_replaced_bc (Concrete bc); + (* Update the value *) + V.Bottom) + else + (* Update the outer borrows before diving into the borrowed value *) + let outer = update_outer_borrows io outer (Borrow l') in + V.Borrow (super#visit_MutBorrow outer l' bv) + + method! visit_ALoan outer lc = + (* Note that the children avalues are just other, independent loans, + * so we don't need to update the outer borrows when diving in. + * We keep track of the parents/children relationship only because we + * need it to properly instantiate the backward functions when generating + * the pure translation. *) + match lc with + | V.AMutLoan (bid, av) -> + (* Nothing special to do *) + V.ALoan (super#visit_AMutLoan outer bid av) + | V.ASharedLoan (bids, v, av) -> + (* Explore the shared value - we need to update the outer borrows *) + let souter = update_outer_borrows io outer (Borrows bids) in + let v = super#visit_typed_value souter v in + (* Explore the child avalue - we keep the same outer borrows *) + let av = super#visit_typed_avalue outer av in + (* Reconstruct *) + V.ALoan (V.ASharedLoan (bids, v, av)) + | V.AEndedMutLoan { given_back; child } -> + (* The loan has ended, so no need to update the outer borrows *) + V.ALoan (super#visit_AEndedMutLoan outer given_back child) + | V.AEndedSharedLoan (v, av) -> + (* The loan has ended, so no need to update the outer borrows *) + V.ALoan (super#visit_AEndedSharedLoan outer v av) + | V.AIgnoredMutLoan (bid, av) -> + (* Nothing special to do *) + V.ALoan (super#visit_AIgnoredMutLoan outer bid av) + | V.AEndedIgnoredMutLoan { given_back; child } -> + (* Nothing special to do *) + V.ALoan (super#visit_AEndedIgnoredMutLoan outer given_back child) + | V.AIgnoredSharedLoan av -> + (* Nothing special to do *) + V.ALoan (super#visit_AIgnoredSharedLoan outer av) + (** We reimplement [visit_ALoan] because we may have to update the + outer borrows *) + + method! visit_ABorrow outer bc = + match bc with + | V.AMutBorrow (bid, av) -> + (* Check if this is the borrow we are looking for *) + if bid = l then ( + (* When ending a mut borrow, there are two cases: + * - in the general case, we have to end the whole abstraction + * (and thus raise an exception to signal that to the caller) + * - in some situations, the associated loan is inside the same + * abstraction as the borrow. In this situation, we can end + * the borrow without ending the whole abstraction, and we + * simply move the child avalue around. + *) + (* Check there are outer borrows, or if we need to end the whole + * abstraction *) + raise_if_outer outer; + (* Register the update *) + set_replaced_bc (Abstract bc); + (* Update the value - note that we are necessarily in the second + * of the two cases described above *) + V.ABottom) + else + (* Update the outer borrows before diving into the child avalue *) + let outer = update_outer_borrows io outer (Borrow bid) in + V.ABorrow (super#visit_AMutBorrow outer bid av) + | V.ASharedBorrow bid -> + (* Check if this is the borrow we are looking for *) + if bid = l then ( + (* Check there are outer borrows, or if we need to end the whole + * abstraction *) + raise_if_outer outer; + (* Register the update *) + set_replaced_bc (Abstract bc); + (* Update the value - note that we are necessarily in the second + * of the two cases described above *) + V.ABottom) + else V.ABorrow (super#visit_ASharedBorrow outer bid) + | V.AIgnoredMutBorrow av -> + (* Nothing special to do *) + V.ABorrow (super#visit_AIgnoredMutBorrow outer av) + | V.AProjSharedBorrow asb -> + (* Check if the borrow we are looking for is in the asb *) + if borrow_in_asb l asb then ( + (* Check there are outer borrows, or if we need to end the whole + * abstraction *) + raise_if_outer outer; + (* Register the update *) + set_replaced_bc (Abstract bc); + (* Update the value - note that we are necessarily in the second + * of the two cases described above *) + let asb = remove_borrow_from_asb l asb in + V.ABorrow (V.AProjSharedBorrow asb)) + else + (* Nothing special to do *) + V.ABorrow (super#visit_AProjSharedBorrow outer asb) + + method! visit_abs outer abs = + (* Update the outer abs *) + let outer_abs, outer_borrows = outer in + assert (Option.is_none outer_abs); + assert (Option.is_none outer_borrows); + let outer = (Some abs.V.abs_id, None) in + super#visit_abs outer abs + end + in + (* Catch the exceptions - raised if there are outer borrows *) + try + let ctx = obj#visit_eval_ctx (None, None) ctx in + Ok (ctx, !replaced_bc) + with FoundOuter outers -> Error outers + +(** Auxiliary function to end borrows. See [give_back]. + + When we end a mutable borrow, we need to "give back" the value it contained + to its original owner by reinserting it at the proper position. + + Note that this function checks that there is exactly one loan to which we + give the value back. + TODO: this was not the case before, so some sanity checks are not useful anymore. + *) +let give_back_value (config : C.config) (bid : V.BorrowId.id) + (nv : V.typed_value) (ctx : C.eval_ctx) : C.eval_ctx = + (* We use a reference to check that we updated exactly one loan *) + let replaced : bool ref = ref false in + let set_replaced () = + assert (not !replaced); + replaced := true + in + (* Whenever giving back symbolic values, they shouldn't contain already ended regions *) + let check_symbolic_no_ended = true in + (* We sometimes need to reborrow values while giving a value back due: prepare that *) + let allow_reborrows = true in + let fresh_reborrow, apply_registered_reborrows = + prepare_reborrows config allow_reborrows ctx + in + (* The visitor to give back the values *) + let obj = + object (self) + inherit [_] C.map_eval_ctx as super + + method! visit_Loan opt_abs lc = + match lc with + | V.SharedLoan (bids, v) -> + (* We are giving back a value (i.e., the content of a *mutable* + * borrow): nothing special to do *) + V.Loan (super#visit_SharedLoan opt_abs bids v) + | V.MutLoan bid' -> + (* Check if this is the loan we are looking for *) + if bid' = bid then ( + set_replaced (); + nv.V.value) + else V.Loan (super#visit_MutLoan opt_abs bid') + + method! visit_typed_avalue opt_abs (av : V.typed_avalue) : V.typed_avalue + = + match av.V.value with + | V.ALoan lc -> + let value = self#visit_typed_ALoan opt_abs av.V.ty lc in + ({ av with V.value } : V.typed_avalue) + | _ -> super#visit_typed_avalue opt_abs av + (** This is a bit annoying, but as we need the type of the avalue we + are exploring, in order to be able to project the value we give + back, we need to reimplement [visit_typed_avalue] instead of + [visit_ALoan] *) + + method visit_typed_ALoan (opt_abs : V.abs option) (ty : T.rty) + (lc : V.aloan_content) : V.avalue = + (* Preparing a bit *) + let regions = + match opt_abs with + | None -> failwith "Unreachable" + | Some abs -> abs.V.regions + in + match lc with + | V.AMutLoan (bid', child) -> + if bid' = bid then ( + (* This is the loan we are looking for: apply the projection to + * the value we give back and replaced this mutable loan with + * an ended loan *) + (* Register the insertion *) + set_replaced (); + (* Apply the projection *) + let given_back = + apply_proj_borrows check_symbolic_no_ended ctx fresh_reborrow + regions nv ty + in + (* Return the new value *) + V.ALoan (V.AEndedMutLoan { given_back; child })) + else + (* Continue exploring *) + V.ALoan (super#visit_AMutLoan opt_abs bid' child) + | V.ASharedLoan (bids, v, av) -> + (* We are giving back a value to a *mutable* loan: nothing special to do *) + V.ALoan (super#visit_ASharedLoan opt_abs bids v av) + | V.AEndedMutLoan { given_back; child } -> + (* Nothing special to do *) + V.ALoan (super#visit_AEndedMutLoan opt_abs given_back child) + | V.AEndedSharedLoan (v, av) -> + (* Nothing special to do *) + V.ALoan (super#visit_AEndedSharedLoan opt_abs v av) + | V.AIgnoredMutLoan (bid', child) -> + (* This loan is ignored, but we may have to project on a subvalue + * of the value which is given back *) + if bid' = bid then + (* Note that we replace the ignored mut loan by an *ended* ignored + * mut loan. Also, this is not the loan we are looking for *per se*: + * we don't register the fact that we inserted the value somewhere + * (i.e., we don't call [set_replaced]) *) + let given_back = + apply_proj_borrows check_symbolic_no_ended ctx fresh_reborrow + regions nv ty + in + V.ALoan (V.AEndedIgnoredMutLoan { given_back; child }) + else V.ALoan (super#visit_AIgnoredMutLoan opt_abs bid' child) + | V.AEndedIgnoredMutLoan { given_back; child } -> + (* Nothing special to do *) + V.ALoan (super#visit_AEndedIgnoredMutLoan opt_abs given_back child) + | V.AIgnoredSharedLoan av -> + (* Nothing special to do *) + V.ALoan (super#visit_AIgnoredSharedLoan opt_abs av) + (** We are not specializing an already existing method, but adding a + new method (for projections, we need type information) *) + + method! visit_Abs opt_abs abs = + (* We remember in which abstraction we are before diving - + * this is necessary for projecting values: we need to know + * over which regions to project *) + assert (Option.is_none opt_abs); + super#visit_Abs (Some abs) abs + end + in + + (* Explore the environment *) + let ctx = obj#visit_eval_ctx None ctx in + (* Check we gave back to exactly one loan *) + assert !replaced; + (* Apply the reborrows *) + apply_registered_reborrows ctx + +(** Auxiliary function to end borrows. See [give_back]. + + This function is similar to [give_back_value] but gives back an [avalue] + (coming from an abstraction). + + It is used when ending a borrow inside an abstraction, when the corresponding + loan is inside the same abstraction (in which case we don't need to end the whole + abstraction). + + REMARK: this function can't be used to give back the values borrowed by + end abstraction when ending this abstraction. When doing this, we need + to convert the [avalue] to a [value] by introducing the proper symbolic values. + *) +let give_back_avalue (_config : C.config) (bid : V.BorrowId.id) + (nv : V.typed_avalue) (ctx : C.eval_ctx) : C.eval_ctx = + (* We use a reference to check that we updated exactly one loan *) + let replaced : bool ref = ref false in + let set_replaced () = + assert (not !replaced); + replaced := true + in + let obj = + object (self) + inherit [_] C.map_eval_ctx as super + + method! visit_typed_avalue opt_abs (av : V.typed_avalue) : V.typed_avalue + = + match av.V.value with + | V.ALoan lc -> + let value = self#visit_typed_ALoan opt_abs av.V.ty lc in + ({ av with V.value } : V.typed_avalue) + | _ -> super#visit_typed_avalue opt_abs av + (** This is a bit annoying, but as we need the type of the avalue we + are exploring, in order to be able to project the value we give + back, we need to reimplement [visit_typed_avalue] instead of + [visit_ALoan] *) + + method visit_typed_ALoan (opt_abs : V.abs option) (ty : T.rty) + (lc : V.aloan_content) : V.avalue = + match lc with + | V.AMutLoan (bid', child) -> + if bid' = bid then ( + (* This is the loan we are looking for: apply the projection to + * the value we give back and replaced this mutable loan with + * an ended loan *) + (* Register the insertion *) + set_replaced (); + (* Sanity check *) + assert (nv.V.ty = ty); + (* Return the new value *) + V.ALoan (V.AEndedMutLoan { given_back = nv; child })) + else + (* Continue exploring *) + V.ALoan (super#visit_AMutLoan opt_abs bid' child) + | V.ASharedLoan (bids, v, av) -> + (* We are giving back a value to a *mutable* loan: nothing special to do *) + V.ALoan (super#visit_ASharedLoan opt_abs bids v av) + | V.AEndedMutLoan { given_back; child } -> + (* Nothing special to do *) + V.ALoan (super#visit_AEndedMutLoan opt_abs given_back child) + | V.AEndedSharedLoan (v, av) -> + (* Nothing special to do *) + V.ALoan (super#visit_AEndedSharedLoan opt_abs v av) + | V.AIgnoredMutLoan (bid', child) -> + (* This loan is ignored, but we may have to project on a subvalue + * of the value which is given back *) + if bid' = bid then ( + (* Note that we replace the ignored mut loan by an *ended* ignored + * mut loan. Also, this is not the loan we are looking for *per se*: + * we don't register the fact that we inserted the value somewhere + * (i.e., we don't call [set_replaced]) *) + (* Sanity check *) + assert (nv.V.ty = ty); + V.ALoan (V.AEndedIgnoredMutLoan { given_back = nv; child })) + else V.ALoan (super#visit_AIgnoredMutLoan opt_abs bid' child) + | V.AEndedIgnoredMutLoan { given_back; child } -> + (* Nothing special to do *) + V.ALoan (super#visit_AEndedIgnoredMutLoan opt_abs given_back child) + | V.AIgnoredSharedLoan av -> + (* Nothing special to do *) + V.ALoan (super#visit_AIgnoredSharedLoan opt_abs av) + (** We are not specializing an already existing method, but adding a + new method (for projections, we need type information) *) + end + in + + (* Explore the environment *) + let ctx = obj#visit_eval_ctx None ctx in + (* Check we gave back to exactly one loan *) + assert !replaced; + (* Return *) + ctx + +(** Auxiliary function to end borrows. See [give_back]. + + When we end a shared borrow, we need to remove the borrow id from the list + of borrows to the shared value. + + Note that this function checks that there is exactly one shared loan that + we update. + TODO: this was not the case before, so some sanity checks are not useful anymore. + *) +let give_back_shared _config (bid : V.BorrowId.id) (ctx : C.eval_ctx) : + C.eval_ctx = + (* We use a reference to check that we updated exactly one loan *) + let replaced : bool ref = ref false in + let set_replaced () = + assert (not !replaced); + replaced := true + in + let obj = + object + inherit [_] C.map_eval_ctx as super + + method! visit_Loan opt_abs lc = + match lc with + | V.SharedLoan (bids, shared_value) -> + if V.BorrowId.Set.mem bid bids then ( + (* This is the loan we are looking for *) + set_replaced (); + (* If there remains exactly one borrow identifier, we need + * to end the loan. Otherwise, we just remove the current + * loan identifier *) + if V.BorrowId.Set.cardinal bids = 1 then shared_value.V.value + else + V.Loan + (V.SharedLoan (V.BorrowId.Set.remove bid bids, shared_value))) + else + (* Not the loan we are looking for: continue exploring *) + V.Loan (super#visit_SharedLoan opt_abs bids shared_value) + | V.MutLoan bid' -> + (* We are giving back a *shared* borrow: nothing special to do *) + V.Loan (super#visit_MutLoan opt_abs bid') + + method! visit_ALoan opt_abs lc = + match lc with + | V.AMutLoan (bid, av) -> + (* Nothing special to do (we are giving back a *shared* borrow) *) + V.ALoan (super#visit_AMutLoan opt_abs bid av) + | V.ASharedLoan (bids, shared_value, child) -> + if V.BorrowId.Set.mem bid bids then ( + (* This is the loan we are looking for *) + set_replaced (); + (* If there remains exactly one borrow identifier, we need + * to end the loan. Otherwise, we just remove the current + * loan identifier *) + if V.BorrowId.Set.cardinal bids = 1 then + V.ALoan (V.AEndedSharedLoan (shared_value, child)) + else + V.ALoan + (V.ASharedLoan + (V.BorrowId.Set.remove bid bids, shared_value, child))) + else + (* Not the loan we are looking for: continue exploring *) + V.ALoan (super#visit_ASharedLoan opt_abs bids shared_value child) + | V.AEndedMutLoan { given_back; child } -> + (* Nothing special to do (the loan has ended) *) + V.ALoan (super#visit_AEndedMutLoan opt_abs given_back child) + | V.AEndedSharedLoan (v, av) -> + (* Nothing special to do (the loan has ended) *) + V.ALoan (super#visit_AEndedSharedLoan opt_abs v av) + | V.AIgnoredMutLoan (bid, av) -> + (* Nothing special to do (we are giving back a *shared* borrow) *) + V.ALoan (super#visit_AIgnoredMutLoan opt_abs bid av) + | V.AEndedIgnoredMutLoan { given_back; child } -> + (* Nothing special to do *) + V.ALoan (super#visit_AEndedIgnoredMutLoan opt_abs given_back child) + | V.AIgnoredSharedLoan av -> + (* Nothing special to do *) + V.ALoan (super#visit_AIgnoredSharedLoan opt_abs av) + end + in + + (* Explore the environment *) + let ctx = obj#visit_eval_ctx None ctx in + (* Check we gave back to exactly one loan *) + assert !replaced; + (* Return *) + ctx + +(** When copying values, we duplicate the shared borrows. This is tantamount + to reborrowing the shared value. The following function applies this change + to an environment by inserting a new borrow id in the set of borrows tracked + by a shared value, referenced by the [original_bid] argument. + *) +let reborrow_shared (original_bid : V.BorrowId.id) (new_bid : V.BorrowId.id) + (ctx : C.eval_ctx) : C.eval_ctx = + (* Keep track of changes *) + let r = ref false in + let set_ref () = + assert (not !r); + r := true + in + + let obj = + object + inherit [_] C.map_env as super + + method! visit_SharedLoan env bids sv = + (* Shared loan: check if the borrow id we are looking for is in the + set of borrow ids. If yes, insert the new borrow id, otherwise + explore inside the shared value *) + if V.BorrowId.Set.mem original_bid bids then ( + set_ref (); + let bids' = V.BorrowId.Set.add new_bid bids in + V.SharedLoan (bids', sv)) + else super#visit_SharedLoan env bids sv + + method! visit_ASharedLoan env bids v av = + (* This case is similar to the [SharedLoan] case *) + if V.BorrowId.Set.mem original_bid bids then ( + set_ref (); + let bids' = V.BorrowId.Set.add new_bid bids in + V.ASharedLoan (bids', v, av)) + else super#visit_ASharedLoan env bids v av + end + in + + let env = obj#visit_env () ctx.env in + (* Check that we reborrowed once *) + assert !r; + { ctx with env } + +(** Auxiliary function: see [end_borrow_in_env] *) +let give_back (config : C.config) (l : V.BorrowId.id) (bc : g_borrow_content) + (ctx : C.eval_ctx) : C.eval_ctx = + (* This is used for sanity checks *) + let sanity_ek = + { enter_shared_loans = true; enter_mut_borrows = true; enter_abs = true } + in + match bc with + | Concrete (V.MutBorrow (l', tv)) -> + (* Sanity check *) + assert (l' = l); + (* Check that the corresponding loan is somewhere - purely a sanity check *) + assert (Option.is_some (lookup_loan_opt sanity_ek l ctx)); + (* Update the context *) + give_back_value config l tv ctx + | Concrete (V.SharedBorrow l' | V.InactivatedMutBorrow l') -> + (* Sanity check *) + assert (l' = l); + (* Check that the borrow is somewhere - purely a sanity check *) + assert (Option.is_some (lookup_loan_opt sanity_ek l ctx)); + (* Update the context *) + give_back_shared config l ctx + | Abstract (V.AMutBorrow (l', av)) -> + (* Sanity check *) + assert (l' = l); + (* Check that the corresponding loan is somewhere - purely a sanity check *) + assert (Option.is_some (lookup_loan_opt sanity_ek l ctx)); + (* Update the context *) + give_back_avalue config l av ctx + | Abstract (V.ASharedBorrow l') -> + (* Sanity check *) + assert (l' = l); + (* Check that the borrow is somewhere - purely a sanity check *) + assert (Option.is_some (lookup_loan_opt sanity_ek l ctx)); + (* Update the context *) + give_back_shared config l ctx + | Abstract (V.AProjSharedBorrow asb) -> + (* Sanity check *) + assert (borrow_in_asb l asb); + (* Update the context *) + give_back_shared config l ctx + | Abstract (V.AIgnoredMutBorrow _) -> failwith "Unreachable" + +(** Convert an [avalue] to a [value]. + + This function is used when ending abstractions: whenever we end a borrow + in an abstraction, we converted the borrowed [avalue] to a fresh symbolic + [value], then give back this [value] to the context. + + Note that some regions may have ended in the symbolic value we generate. + For instance, consider the following function signature: + ``` + fn f<'a>(x : &'a mut &'a mut u32); + ``` + When ending the abstraction, the value given back for the outer borrow + should be ⊥. In practice, we will give back a symbolic value which can't + be expanded (because expanding this symbolic value would require expanding + a reference whose region has already ended). + *) +let convert_avalue_to_value (av : V.typed_avalue) (ctx : C.eval_ctx) : + C.eval_ctx * V.typed_value = + (* Convert the type *) + let ty = Subst.erase_regions av.V.ty in + (* Generate the fresh a symbolic value *) + let ctx, sv_id = C.fresh_symbolic_value_id ctx in + let svalue : V.symbolic_value = { V.sv_id; sv_ty = av.V.ty } in + let value : V.symbolic_proj_comp = + (* Note that the set of ended regions is empty: we shouldn't have to take + * into account any ended regions at this point, otherwise we would be in + * the first case where we should return ⊥ *) + { V.svalue; V.rset_ended = T.RegionId.Set.empty } + in + let value = V.Symbolic value in + (ctx, { V.value; V.ty }) + +(** End a borrow identified by its borrow id in a context + + First lookup the borrow in the context and replace it with [Bottom]. + Then, check that there is an associated loan in the context. When moving + values, before putting the value in its destination, we get an + intermediate state where some values are "outside" the context and thus + inaccessible. As [give_back_value] just performs a map for instance (TODO: + not the case anymore), we need to check independently that there is indeed a + loan ready to receive the value we give back (note that we also have other + invariants like: there is exacly one mutable loan associated to a mutable + borrow, etc. but they are more easily maintained). + Note that in theory, we shouldn't never reach a problematic state as the + one we describe above, because when we move a value we need to end all the + loans inside before moving it. Still, it is a very useful sanity check. + Finally, give the values back. + + Of course, we end outer borrows before updating the target borrow if it + proves necessary: this is controled by the [io] parameter. If it is [Inner], + we allow ending inner borrows (without ending the outer borrows first), + otherwise we only allow ending outer borrows. + If a borrow is inside an abstraction, we need to end the whole abstraction, + at the exception of the case where the loan corresponding to the borrow is + inside the same abstraction. We control this with the [allowed_abs] parameter: + if it is not `None`, we allow ending a borrow if it is inside the given + abstraction. In practice, if the value is `Some abs_id`, we should have + checked that the corresponding loan is inside the abstraction given by + `abs_id` before. In practice, only [end_borrow] should call itself + with `allowed_abs = Some ...`, all the other calls should use `allowed_abs = None`: + if you look ath the implementation details, `end_borrow` performs + all tne necessary checks in case a borrow is inside an abstraction. + *) +let rec end_borrow (config : C.config) (io : inner_outer) + (allowed_abs : V.AbstractionId.id option) (l : V.BorrowId.id) + (ctx : C.eval_ctx) : C.eval_ctx = + match end_borrow_get_borrow io allowed_abs l ctx with + (* Two cases: + * - error: we found outer borrows (end them first) + * - success: we didn't find outer borrows when updating (but maybe we actually + didn't find the borrow we were looking for...) + *) + | Error outer -> ( + (* End the outer borrows, abstraction, then try again to end the target + * borrow (if necessary) *) + match outer with + | OuterBorrows (Borrows bids) -> + (* Note that when ending outer borrows, we use io=Outer. However, + * we shouldn't need to end outer borrows if io=Inner, so we just + * add the following assertion *) + assert (io = Outer); + (* Note that we might get there with `allowed_abs <> None`: we might + * be trying to end a borrow inside an abstraction, but which is actually + * inside another borrow *) + let allowed_abs' = None in + let ctx = end_borrows config io allowed_abs' bids ctx in + (* Retry to end the borrow *) + end_borrow config io allowed_abs l ctx + | OuterBorrows (Borrow bid) -> + (* See the comments for the previous case *) + assert (io = Outer); + let allowed_abs' = None in + let ctx = end_borrow config io allowed_abs' bid ctx in + (* Retry to end the borrow *) + end_borrow config io allowed_abs l ctx + | OuterAbs abs_id -> ( + (* The borrow is inside an asbtraction: check if the corresponding + * loan is inside the same abstraction. If this is the case, we end + * the borrow without ending the abstraction. If not, we need to + * end the whole abstraction *) + (* Note that we can lookup the loan anywhere *) + let ek = + { + enter_shared_loans = true; + enter_mut_borrows = true; + enter_abs = true; + } + in + match lookup_loan ek l ctx with + | AbsId loan_abs_id, _ -> + if loan_abs_id = abs_id then ( + (* Same abstraction! We can end the borrow *) + let ctx = end_borrow config io (Some abs_id) l ctx in + (* Sanity check *) + assert (Option.is_none (lookup_borrow_opt ek l ctx)); + ctx) + else + (* Not the same abstraction: we need to end the whole abstraction. + * By doing that we should have ended the target borrow (see the + * below sanity check) *) + let ctx = end_abstraction config abs_id ctx in + (* Sanity check: we ended the target borrow *) + assert (Option.is_none (lookup_borrow_opt ek l ctx)); + ctx + | VarId _, _ -> + (* The loan is not inside the same abstraction (actually inside + * a non-abstraction value): we need to end the whole abstraction *) + let ctx = end_abstraction config abs_id ctx in + (* Sanity check: we ended the target borrow *) + assert (Option.is_none (lookup_borrow_opt ek l ctx)); + ctx)) + | Ok (ctx, None) -> + (* It is possible that we can't find a borrow in symbolic mode (ending + * an abstraction may end several borrows at once *) + assert (config.mode = SymbolicMode); + ctx + (* We found a borrow: give the value back (i.e., update the corresponding loan) *) + | Ok (ctx, Some bc) -> give_back config l bc ctx + +and end_borrows (config : C.config) (io : inner_outer) + (allowed_abs : V.AbstractionId.id option) (lset : V.BorrowId.Set.t) + (ctx : C.eval_ctx) : C.eval_ctx = + V.BorrowId.Set.fold + (fun id ctx -> end_borrow config io allowed_abs id ctx) + lset ctx + +and end_abstraction (config : C.config) (abs_id : V.AbstractionId.id) + (ctx : C.eval_ctx) : C.eval_ctx = + (* Lookup the abstraction *) + let abs = C.ctx_lookup_abs ctx abs_id in + (* End the parent abstractions first *) + let ctx = end_abstractions config abs.parents ctx in + (* End the loans inside the abstraction *) + let ctx = end_abstraction_loans config abs_id ctx in + (* End the abstraction itself by redistributing the borrows it contains *) + let ctx = end_abstraction_borrows config abs_id ctx in + (* End the regions owned by the abstraction *) + let ctx = end_abstraction_regions config abs_id ctx in + (* Remove all the references to the id of the current abstraction, and remove + * the abstraction itself *) + end_abstraction_remove_from_context config abs_id ctx + +and end_abstractions (config : C.config) (abs_ids : V.AbstractionId.set_t) + (ctx : C.eval_ctx) : C.eval_ctx = + V.AbstractionId.Set.fold + (fun id ctx -> end_abstraction config id ctx) + abs_ids ctx + +and end_abstraction_loans (config : C.config) (abs_id : V.AbstractionId.id) + (ctx : C.eval_ctx) : C.eval_ctx = + (* Lookup the abstraction *) + let abs = C.ctx_lookup_abs ctx abs_id in + (* End the first loan we find *) + let obj = + object + inherit [_] V.iter_abs as super + + method! visit_aloan_content env lc = + match lc with + | V.AMutLoan (bid, _) -> raise (FoundBorrowIds (Borrow bid)) + | V.ASharedLoan (bids, _, _) -> raise (FoundBorrowIds (Borrows bids)) + | V.AEndedMutLoan { given_back; child } -> + super#visit_AEndedMutLoan env given_back child + | V.AEndedSharedLoan (v, av) -> super#visit_AEndedSharedLoan env v av + | V.AIgnoredMutLoan (bid, av) -> + (* Note that this loan can't come from a parent abstraction, because + * we should have ended them already) *) + super#visit_AIgnoredMutLoan env bid av + | V.AEndedIgnoredMutLoan { given_back; child } -> + super#visit_AEndedIgnoredMutLoan env given_back child + | V.AIgnoredSharedLoan av -> super#visit_AIgnoredSharedLoan env av + end + in + try + (* Check if there are loans *) + obj#visit_abs () abs; + (* No loans: nothing to update *) + ctx + with (* There are loans: end them, then recheck *) + | FoundBorrowIds bids -> + let ctx = + match bids with + | Borrow bid -> end_outer_borrow config bid ctx + | Borrows bids -> end_outer_borrows config bids ctx + in + (* Recheck *) + end_abstraction_loans config abs_id ctx + +and end_abstraction_borrows (config : C.config) (abs_id : V.AbstractionId.id) + (ctx : C.eval_ctx) : C.eval_ctx = + (* Note that the abstraction mustn't contain any loans *) + (* We end the borrows, starting with the *inner* ones. This is important + when considering nested borrows which have the same lifetime. + + For instance: + ``` + x -> mut_loan l1 + px -> mut_loan l0 + abs0 { a_mut_borrow l0 (a_mut_borrow l1 (U32 3)) } + ``` + + becomes (`U32 3` doesn't contain ⊥, so we give back a symbolic value): + ``` + x -> @s0 + px -> mut_loan l0 + abs0 { a_mut_borrow l0 ⊥ } + ``` + + then (the borrowed value contains ⊥, we give back ⊥): + ``` + x -> @s0 + px -> ⊥ + abs0 { ⊥ } + ``` + *) + (* We explore in-depth and use exceptions. When exploring a borrow, if + * the exploration didn't trigger an exception, it means there are no + * inner borrows to end: we can thus trigger an exception for the current + * borrow. *) + let obj = + object + inherit [_] V.iter_abs as super + + method! visit_aborrow_content env bc = + (* In-depth exploration *) + super#visit_aborrow_content env bc; + (* No exception was raise: we can raise an exception for the + * current borrow *) + match bc with + | V.AMutBorrow (_, _) | V.ASharedBorrow _ -> + (* Raise an exception *) + raise (FoundABorrowContent bc) + | V.AProjSharedBorrow asb -> + (* Raise an exception only if the asb contains borrows *) + if + List.exists + (fun x -> match x with V.AsbBorrow _ -> true | _ -> false) + asb + then raise (FoundABorrowContent bc) + else () + | V.AIgnoredMutBorrow _ -> + (* Nothing to do for ignored borrows *) + () + end + in + (* Lookup the abstraction *) + let abs = C.ctx_lookup_abs ctx abs_id in + try + (* Explore the abstraction, looking for borrows *) + obj#visit_abs () abs; + (* No borrows: nothing to update *) + ctx + with + (* There are borrows: end them, then reexplore *) + | FoundABorrowContent bc -> + (* First, replace the borrow by ⊥ *) + let bid = + match bc with + | V.AMutBorrow (bid, _) | V.ASharedBorrow bid -> bid + | V.AProjSharedBorrow asb -> ( + (* There should be at least one borrow identifier in the set, which we + * can use to identify the whole set *) + match + List.find + (fun x -> match x with V.AsbBorrow _ -> true | _ -> false) + asb + with + | V.AsbBorrow bid -> bid + | _ -> failwith "Unexpected") + | V.AIgnoredMutBorrow _ -> failwith "Unexpected" + in + let ctx = update_aborrow ek_all bid V.ABottom ctx in + (* Then give back the value *) + let ctx = + match bc with + | V.AMutBorrow (bid, av) -> + (* First, convert the avalue to a (fresh symbolic) value *) + let ctx, v = convert_avalue_to_value av ctx in + give_back_value config bid v ctx + | V.ASharedBorrow bid -> give_back_shared config bid ctx + | V.AProjSharedBorrow _ -> + (* Nothing to do *) + ctx + | V.AIgnoredMutBorrow _ -> failwith "Unexpected" + in + (* Reexplore *) + end_abstraction_borrows config abs_id ctx + +(** Update the symbolic values in a context to register the regions in the + abstraction we are ending as already ended. + Note that this function also checks that no symbolic value in an abstraction + contains regions which we are ending. + Of course, we ignore the abstraction we are currently ending... + *) +and end_abstraction_regions (_config : C.config) (abs_id : V.AbstractionId.id) + (ctx : C.eval_ctx) : C.eval_ctx = + (* Lookup the abstraction to retrieve the set of owned regions *) + let abs = C.ctx_lookup_abs ctx abs_id in + let ended_regions = abs.V.regions in + (* Update all the symbolic values in the context *) + let obj = + object + inherit [_] C.map_eval_ctx as super + + method! visit_Symbolic _ sproj = + let sproj = + { + sproj with + V.rset_ended = T.RegionId.Set.union sproj.V.rset_ended ended_regions; + } + in + V.Symbolic sproj + + method! visit_aproj (abs_regions : T.RegionId.set_t option) aproj = + (* Sanity check *) + (match aproj with + | V.AProjLoans _ -> () + | V.AProjBorrows (sv, ty) -> ( + match abs_regions with + | None -> failwith "Unexpected" + | Some abs_regions -> + assert ( + not + (projections_intersect sv.V.sv_ty ended_regions ty + abs_regions)))); + (* Return - nothing to update *) + aproj + + method! visit_abs (regions : T.RegionId.set_t option) abs = + if abs.V.abs_id = abs_id then abs + else ( + assert (Option.is_none regions); + (* Check that we don't project over already ended regions *) + assert (T.RegionId.Set.disjoint ended_regions abs.V.regions); + (* Remember the set of regions owned by the abstraction *) + let regions = Some abs.V.regions in + super#visit_abs regions abs) + (** Whenever we dive in an abstraction, we need to keep track of the + set of regions owned by the abstraction. + Also: we don't dive in the abstraction we are currently ending... *) + end + in + (* Update the context *) + obj#visit_eval_ctx None ctx + +(** Remove an abstraction from the context, as well as all its references *) +and end_abstraction_remove_from_context (_config : C.config) + (abs_id : V.AbstractionId.id) (ctx : C.eval_ctx) : C.eval_ctx = + let map_env_elem (ev : C.env_elem) : C.env_elem option = + match ev with + | C.Var (_, _) | C.Frame -> Some ev + | C.Abs abs -> + if abs.abs_id = abs_id then None + else + let parents = V.AbstractionId.Set.remove abs_id abs.parents in + Some (C.Abs { abs with V.parents }) + in + let env = List.filter_map map_env_elem ctx.C.env in + { ctx with C.env } + +and end_outer_borrow config = end_borrow config Outer None + +and end_outer_borrows config = end_borrows config Outer None + +and end_inner_borrow config = end_borrow config Inner None + +and end_inner_borrows config = end_borrows config Inner None + +(** Helper function: see [activate_inactivated_mut_borrow]. + + This function updates the shared loan to a mutable loan (we then update + the borrow with another helper). Of course, the shared loan must contain + exactly one borrow id (the one we give as parameter), otherwise we can't + promote it. Also, the shared value mustn't contain any loan. + + The returned value (previously shared) is checked: + - it mustn't contain loans + - it mustn't contain [Bottom] + - it mustn't contain inactivated borrows + TODO: this kind of checks should be put in an auxiliary helper, because + they are redundant + *) +let promote_shared_loan_to_mut_loan (l : V.BorrowId.id) (ctx : C.eval_ctx) : + C.eval_ctx * V.typed_value = + (* Lookup the shared loan *) + let ek = + { enter_shared_loans = false; enter_mut_borrows = true; enter_abs = false } + in + match lookup_loan ek l ctx with + | _, Concrete (V.MutLoan _) -> + failwith "Expected a shared loan, found a mut loan" + | _, Concrete (V.SharedLoan (bids, sv)) -> + (* Check that there is only one borrow id (l) and update the loan *) + assert (V.BorrowId.Set.mem l bids && V.BorrowId.Set.cardinal bids = 1); + (* We need to check that there aren't any loans in the value: + we should have gotten rid of those already, but it is better + to do a sanity check. *) + assert (not (loans_in_value sv)); + (* Check there isn't [Bottom] (this is actually an invariant *) + assert (not (bottom_in_value sv)); + (* Check there aren't inactivated borrows *) + assert (not (inactivated_in_value sv)); + (* Update the loan content *) + let ctx = update_loan ek l (V.MutLoan l) ctx in + (* Return *) + (ctx, sv) + | _, Abstract _ -> + (* I don't think it is possible to have two-phase borrows involving borrows + * returned by abstractions. I'm not sure how we could handle that anyway. *) + failwith + "Can't promote a shared loan to a mutable loan if the loan is inside \ + an abstraction" + +(** Helper function: see [activate_inactivated_mut_borrow]. + + This function updates a shared borrow to a mutable borrow. + *) +let promote_inactivated_borrow_to_mut_borrow (l : V.BorrowId.id) + (borrowed_value : V.typed_value) (ctx : C.eval_ctx) : C.eval_ctx = + (* Lookup the inactivated borrow - note that we don't go inside borrows/loans: + there can't be inactivated borrows inside other borrows/loans + *) + let ek = + { enter_shared_loans = false; enter_mut_borrows = false; enter_abs = false } + in + match lookup_borrow ek l ctx with + | Concrete (V.SharedBorrow _ | V.MutBorrow (_, _)) -> + failwith "Expected an inactivated mutable borrow" + | Concrete (V.InactivatedMutBorrow _) -> + (* Update it *) + update_borrow ek l (V.MutBorrow (l, borrowed_value)) ctx + | Abstract _ -> + (* This can't happen for sure *) + failwith + "Can't promote a shared borrow to a mutable borrow if the borrow is \ + inside an abstraction" + +(** Promote an inactivated mut borrow to a mut borrow. + + The borrow must point to a shared value which is borrowed exactly once. + *) +let rec activate_inactivated_mut_borrow (config : C.config) (io : inner_outer) + (l : V.BorrowId.id) (ctx : C.eval_ctx) : C.eval_ctx = + (* Lookup the value *) + let ek = + { enter_shared_loans = false; enter_mut_borrows = true; enter_abs = false } + in + match lookup_loan ek l ctx with + | _, Concrete (V.MutLoan _) -> failwith "Unreachable" + | _, Concrete (V.SharedLoan (bids, sv)) -> ( + (* If there are loans inside the value, end them. Note that there can't be + inactivated borrows inside the value. + If we perform an update, do a recursive call to lookup the updated value *) + match get_first_loan_in_value sv with + | Some lc -> + (* End the loans *) + let ctx = + match lc with + | V.SharedLoan (bids, _) -> end_outer_borrows config bids ctx + | V.MutLoan bid -> end_outer_borrow config bid ctx + in + (* Recursive call *) + activate_inactivated_mut_borrow config io l ctx + | None -> + (* No loan to end inside the value *) + (* Some sanity checks *) + L.log#ldebug + (lazy + ("activate_inactivated_mut_borrow: resulting value:\n" + ^ V.show_typed_value sv)); + assert (not (loans_in_value sv)); + assert (not (bottom_in_value sv)); + assert (not (inactivated_in_value sv)); + (* End the borrows which borrow from the value, at the exception of + the borrow we want to promote *) + let bids = V.BorrowId.Set.remove l bids in + let allowed_abs = None in + let ctx = end_borrows config io allowed_abs bids ctx in + (* Promote the loan *) + let ctx, borrowed_value = promote_shared_loan_to_mut_loan l ctx in + (* Promote the borrow - the value should have been checked by + [promote_shared_loan_to_mut_loan] + *) + promote_inactivated_borrow_to_mut_borrow l borrowed_value ctx) + | _, Abstract _ -> + (* I don't think it is possible to have two-phase borrows involving borrows + * returned by abstractions. I'm not sure how we could handle that anyway. *) + failwith + "Can't activate an inactivated mutable borrow referencing a loan inside\n\ + \ an abstraction" -- cgit v1.2.3 From bcb49a7ddc86a2d70f7e1010a352c56329f32e14 Mon Sep 17 00:00:00 2001 From: Son Ho Date: Thu, 6 Jan 2022 10:33:47 +0100 Subject: Move some functions from Interpreter to InterpreterExpansion --- src/Interpreter.ml | 484 +------------------------------------------ src/InterpreterExpansion.ml | 490 ++++++++++++++++++++++++++++++++++++++++++++ src/InterpreterUtils.ml | 17 ++ 3 files changed, 508 insertions(+), 483 deletions(-) create mode 100644 src/InterpreterExpansion.ml (limited to 'src') diff --git a/src/Interpreter.ml b/src/Interpreter.ml index 7dc37dff..d8256186 100644 --- a/src/Interpreter.ml +++ b/src/Interpreter.ml @@ -15,6 +15,7 @@ open Utils open InterpreterUtils open InterpreterProjectors open InterpreterBorrows +open InterpreterExpansion (* TODO: check that the value types are correct when evaluating *) (* TODO: for debugging purposes, we might want to put use eval_ctx everywhere @@ -366,168 +367,6 @@ let write_place_unwrap (config : C.config) (access : access_kind) (p : E.place) | Error _ -> failwith "Unreachable" | Ok ctx -> ctx -(** Projector kind *) -type proj_kind = LoanProj | BorrowProj - -(** Auxiliary function. - Apply a symbolic expansion to avalues in a context, targetting a specific - kind of projectors. - - [proj_kind] controls whether we apply the expansion to projectors - on loans or projectors on borrows. - - When dealing with reference expansion, it is necessary to first apply the - expansion on loan projectors, then on borrow projectors. The reason is - that reducing the borrow projectors might require to perform some reborrows, - in which case we need to lookup the corresponding loans in the context. - - [allow_reborrows] controls whether we allow reborrows or not. It is useful - only if we target borrow projectors. - - Also, if this function is called on an expansion for *shared references*, - the proj borrows should already have been expanded. - - TODO: the way this function is used is a bit complex, especially because of - the above condition. Maybe we should have: - 1. a generic function to expand the loan projectors - 2. a function to expand the borrow projectors for non-borrows - 3. specialized functions for mut borrows and shared borrows - Note that 2. and 3. may have a little bit of duplicated code, but hopefully - it would make things clearer. -*) -let apply_symbolic_expansion_to_target_avalues (config : C.config) - (allow_reborrows : bool) (proj_kind : proj_kind) - (original_sv : V.symbolic_value) (expansion : symbolic_expansion) - (ctx : C.eval_ctx) : C.eval_ctx = - (* Symbolic values contained in the expansion might contain already ended regions *) - let check_symbolic_no_ended = false in - (* Prepare reborrows registration *) - let fresh_reborrow, apply_registered_reborrows = - prepare_reborrows config allow_reborrows ctx - in - (* Visitor to apply the expansion *) - let obj = - object - inherit [_] C.map_eval_ctx as super - - method! visit_abs proj_regions abs = - assert (Option.is_none proj_regions); - let proj_regions = Some abs.V.regions in - super#visit_abs proj_regions abs - (** When visiting an abstraction, we remember the regions it owns to be - able to properly reduce projectors when expanding symbolic values *) - - method! visit_ASymbolic proj_regions aproj = - let proj_regions = Option.get proj_regions in - match (aproj, proj_kind) with - | V.AProjLoans sv, LoanProj -> - (* Check if this is the symbolic value we are looking for *) - if same_symbolic_id sv original_sv then - (* Apply the projector *) - let projected_value = - apply_proj_loans_on_symbolic_expansion proj_regions expansion - original_sv.V.sv_ty - in - (* Replace *) - projected_value.V.value - else - (* Not the searched symbolic value: nothing to do *) - super#visit_ASymbolic (Some proj_regions) aproj - | V.AProjBorrows (sv, proj_ty), BorrowProj -> - (* Check if this is the symbolic value we are looking for *) - if same_symbolic_id sv original_sv then - (* Convert the symbolic expansion to a value on which we can - * apply a projector (if the expansion is a reference expansion, - * convert it to a borrow) *) - (* WARNING: we mustn't get there if the expansion is for a shared - * reference. *) - let expansion = - symbolic_expansion_non_shared_borrow_to_value original_sv - expansion - in - (* Apply the projector *) - let projected_value = - apply_proj_borrows check_symbolic_no_ended ctx fresh_reborrow - proj_regions expansion proj_ty - in - (* Replace *) - projected_value.V.value - else - (* Not the searched symbolic value: nothing to do *) - super#visit_ASymbolic (Some proj_regions) aproj - | V.AProjLoans _, BorrowProj | V.AProjBorrows (_, _), LoanProj -> - (* Nothing to do *) - super#visit_ASymbolic (Some proj_regions) aproj - end - in - (* Apply the expansion *) - let ctx = obj#visit_eval_ctx None ctx in - (* Apply the reborrows *) - apply_registered_reborrows ctx - -(** Auxiliary function. - Apply a symbolic expansion to avalues in a context. -*) -let apply_symbolic_expansion_to_avalues (config : C.config) - (allow_reborrows : bool) (original_sv : V.symbolic_value) - (expansion : symbolic_expansion) (ctx : C.eval_ctx) : C.eval_ctx = - let apply_expansion proj_kind ctx = - apply_symbolic_expansion_to_target_avalues config allow_reborrows proj_kind - original_sv expansion ctx - in - (* First target the loan projectors, then the borrow projectors *) - let ctx = apply_expansion LoanProj ctx in - let ctx = apply_expansion BorrowProj ctx in - ctx - -(** Auxiliary function. - - Simply replace the symbolic values (*not avalues*) in the context with - a given value. Will break invariants if not used properly. -*) -let replace_symbolic_values (at_most_once : bool) - (original_sv : V.symbolic_value) (nv : V.value) (ctx : C.eval_ctx) : - C.eval_ctx = - (* Count *) - let replaced = ref false in - let replace () = - if at_most_once then assert (not !replaced); - replaced := true; - nv - in - (* Visitor to apply the substitution *) - let obj = - object - inherit [_] C.map_eval_ctx as super - - method! visit_Symbolic env spc = - if same_symbolic_id spc.V.svalue original_sv then replace () - else super#visit_Symbolic env spc - end - in - (* Apply the substitution *) - let ctx = obj#visit_eval_ctx None ctx in - (* Check that we substituted *) - assert !replaced; - (* Return *) - ctx - -(** Apply a symbolic expansion to a context, by replacing the original - symbolic value with its expanded value. Is valid only if the expansion - is not a borrow (i.e., an adt...). -*) -let apply_symbolic_expansion_non_borrow (config : C.config) - (original_sv : V.symbolic_value) (expansion : symbolic_expansion) - (ctx : C.eval_ctx) : C.eval_ctx = - (* Apply the expansion to non-abstraction values *) - let nv = symbolic_expansion_non_borrow_to_value original_sv expansion in - let at_most_once = false in - let ctx = replace_symbolic_values at_most_once original_sv nv.V.value ctx in - (* Apply the expansion to abstraction values *) - let allow_reborrows = false in - apply_symbolic_expansion_to_avalues config allow_reborrows original_sv - expansion ctx - (** Compute an expanded ADT bottom value *) let compute_expanded_bottom_adt_value (tyctx : T.type_def list) (def_id : T.TypeDefId.id) (opt_variant_id : T.VariantId.id option) @@ -630,312 +469,6 @@ let expand_bottom_value_from_projection (config : C.config) | Ok ctx -> ctx | Error _ -> failwith "Unreachable" -(** Compute the expansion of an adt value. - - The function might return a list of contexts and values if the symbolic - value to expand is an enumeration. - - `expand_enumerations` controls the expansion of enumerations: if false, it - doesn't allow the expansion of enumerations *containing several variants*. - *) -let compute_expanded_symbolic_adt_value (expand_enumerations : bool) - (ended_regions : T.RegionId.set_t) (def_id : T.TypeDefId.id) - (regions : T.RegionId.id T.region list) (types : T.rty list) - (ctx : C.eval_ctx) : (C.eval_ctx * symbolic_expansion) list = - (* Lookup the definition and check if it is an enumeration with several - * variants *) - let def = C.ctx_lookup_type_def ctx def_id in - assert (List.length regions = List.length def.T.region_params); - (* Retrieve, for every variant, the list of its instantiated field types *) - let variants_fields_types = - Subst.type_def_get_instantiated_variants_fields_rtypes def regions types - in - (* Check if there is strictly more than one variant *) - if List.length variants_fields_types > 1 && not expand_enumerations then - failwith "Not allowed to expand enumerations with several variants"; - (* Initialize the expanded value for a given variant *) - let initialize (ctx : C.eval_ctx) - ((variant_id, field_types) : T.VariantId.id option * T.rty list) : - C.eval_ctx * symbolic_expansion = - let ctx, field_values = - List.fold_left_map - (fun ctx (ty : T.rty) -> - mk_fresh_symbolic_proj_comp ended_regions ty ctx) - ctx field_types - in - let see = SeAdt (variant_id, field_values) in - (ctx, see) - in - (* Initialize all the expanded values of all the variants *) - List.map (initialize ctx) variants_fields_types - -let compute_expanded_symbolic_tuple_value (ended_regions : T.RegionId.set_t) - (field_types : T.rty list) (ctx : C.eval_ctx) : - C.eval_ctx * symbolic_expansion = - (* Generate the field values *) - let ctx, field_values = - List.fold_left_map - (fun ctx sv_ty -> mk_fresh_symbolic_proj_comp ended_regions sv_ty ctx) - ctx field_types - in - let variant_id = None in - let see = SeAdt (variant_id, field_values) in - (ctx, see) - -let compute_expanded_symbolic_box_value (ended_regions : T.RegionId.set_t) - (boxed_ty : T.rty) (ctx : C.eval_ctx) : C.eval_ctx * symbolic_expansion = - (* Introduce a fresh symbolic value *) - let ctx, boxed_value = - mk_fresh_symbolic_proj_comp ended_regions boxed_ty ctx - in - let see = SeAdt (None, [ boxed_value ]) in - (ctx, see) - -let expand_symbolic_value_shared_borrow (config : C.config) - (original_sv : V.symbolic_value) (ended_regions : T.RegionId.set_t) - (ref_ty : T.rty) (ctx : C.eval_ctx) : C.eval_ctx = - (* First, replace the projectors on borrows (AProjBorrow and proj_comp) - * The important point is that the symbolic value to expand may appear - * several times, if it has been copied. In this case, we need to introduce - * one fresh borrow id per instance. - *) - let borrows = ref V.BorrowId.Set.empty in - let borrow_counter = ref ctx.C.borrow_counter in - let fresh_borrow () = - let bid', cnt' = V.BorrowId.fresh !borrow_counter in - borrow_counter := cnt'; - borrows := V.BorrowId.Set.add bid' !borrows; - bid' - in - (* Small utility used on shared borrows in abstractions (regular borrow - * projector and asb). - * Returns `Some` if the symbolic value has been expanded to an asb list, - * `None` otherwise *) - let reborrow_ashared proj_regions (sv : V.symbolic_value) (proj_ty : T.rty) : - V.abstract_shared_borrows option = - if same_symbolic_id sv original_sv then - match proj_ty with - | T.Ref (r, ref_ty, T.Shared) -> - (* Projector over the shared value *) - let shared_asb = V.AsbProjReborrows (sv, ref_ty) in - (* Check if the region is in the set of projected regions *) - if region_in_set r proj_regions then - (* In the set: we need to reborrow *) - let bid = fresh_borrow () in - Some [ V.AsbBorrow bid; shared_asb ] - else (* Not in the set: ignore *) - Some [ shared_asb ] - | _ -> failwith "Unexpected" - else None - in - (* Visitor to replace the projectors on borrows *) - let obj = - object - inherit [_] C.map_eval_ctx as super - - method! visit_Symbolic env sv = - if same_symbolic_id sv.V.svalue original_sv then - let bid = fresh_borrow () in - V.Borrow (V.SharedBorrow bid) - else super#visit_Symbolic env sv - - method! visit_Abs proj_regions abs = - assert (Option.is_none proj_regions); - let proj_regions = Some abs.V.regions in - super#visit_Abs proj_regions abs - - method! visit_AProjSharedBorrow proj_regions asb = - let expand_asb (asb : V.abstract_shared_borrow) : - V.abstract_shared_borrows = - match asb with - | V.AsbBorrow _ -> [ asb ] - | V.AsbProjReborrows (sv, proj_ty) -> ( - match reborrow_ashared (Option.get proj_regions) sv proj_ty with - | None -> [ asb ] - | Some asb -> asb) - in - let asb = List.concat (List.map expand_asb asb) in - V.AProjSharedBorrow asb - - method! visit_ASymbolic proj_regions aproj = - match aproj with - | AProjLoans _ -> - (* Loans are handled later *) - super#visit_ASymbolic proj_regions aproj - | AProjBorrows (sv, proj_ty) -> ( - (* Check if we need to reborrow *) - match reborrow_ashared (Option.get proj_regions) sv proj_ty with - | None -> super#visit_ASymbolic proj_regions aproj - | Some asb -> V.ABorrow (V.AProjSharedBorrow asb)) - end - in - (* Call the visitor *) - let ctx = obj#visit_eval_ctx None ctx in - let ctx = { ctx with C.borrow_counter = !borrow_counter } in - (* Finally, replace the projectors on loans *) - let bids = !borrows in - assert (not (V.BorrowId.Set.is_empty bids)); - let ctx, shared_sv = mk_fresh_symbolic_proj_comp ended_regions ref_ty ctx in - let see = SeSharedRef (bids, shared_sv) in - let allow_reborrows = true in - let ctx = - apply_symbolic_expansion_to_avalues config allow_reborrows original_sv see - ctx - in - (* Update the synthesized program *) - S.synthesize_symbolic_expansion_no_branching original_sv see; - (* Return *) - ctx - -let expand_symbolic_value_borrow (config : C.config) - (original_sv : V.symbolic_value) (ended_regions : T.RegionId.set_t) - (region : T.RegionId.id T.region) (ref_ty : T.rty) (rkind : T.ref_kind) - (ctx : C.eval_ctx) : C.eval_ctx = - (* Check that we are allowed to expand the reference *) - assert (not (region_in_set region ended_regions)); - (* Match on the reference kind *) - match rkind with - | T.Mut -> - (* Simple case: simply create a fresh symbolic value and a fresh - * borrow id *) - let ctx, sv = mk_fresh_symbolic_proj_comp ended_regions ref_ty ctx in - let ctx, bid = C.fresh_borrow_id ctx in - let see = SeMutRef (bid, sv) in - (* Expand the symbolic values - we simply perform a substitution (and - * check that we perform exactly one substitution) *) - let nv = symbolic_expansion_non_shared_borrow_to_value original_sv see in - let at_most_once = true in - let ctx = - replace_symbolic_values at_most_once original_sv nv.V.value ctx - in - (* Expand the symbolic avalues *) - let allow_reborrows = true in - let ctx = - apply_symbolic_expansion_to_avalues config allow_reborrows original_sv - see ctx - in - (* Update the synthesized program *) - S.synthesize_symbolic_expansion_no_branching original_sv see; - (* Return *) - ctx - | T.Shared -> - expand_symbolic_value_shared_borrow config original_sv ended_regions - ref_ty ctx - -(** Expand a symbolic value which is not an enumeration with several variants - (i.e., in a situation where it doesn't lead to branching). - - This function is used when exploring paths. - *) -let expand_symbolic_value_no_branching (config : C.config) - (pe : E.projection_elem) (sp : V.symbolic_proj_comp) (ctx : C.eval_ctx) : - C.eval_ctx = - (* Compute the expanded value - note that when doing so, we may introduce - * fresh symbolic values in the context (which thus gets updated) *) - let original_sv = sp.V.svalue in - let rty = original_sv.V.sv_ty in - let ended_regions = sp.V.rset_ended in - let ctx = - match (pe, rty) with - (* "Regular" ADTs *) - | ( Field (ProjAdt (def_id, _opt_variant_id), _), - T.Adt (T.AdtId def_id', regions, types) ) -> ( - assert (def_id = def_id'); - (* Compute the expanded value - there should be exactly one because we - * don't allow to expand enumerations with strictly more than one variant *) - let expand_enumerations = false in - match - compute_expanded_symbolic_adt_value expand_enumerations ended_regions - def_id regions types ctx - with - | [ (ctx, see) ] -> - (* Apply in the context *) - let ctx = - apply_symbolic_expansion_non_borrow config original_sv see ctx - in - (* Update the synthesized program *) - S.synthesize_symbolic_expansion_no_branching original_sv see; - (* Return *) - ctx - | _ -> failwith "Unexpected") - (* Tuples *) - | Field (ProjTuple arity, _), T.Adt (T.Tuple, [], tys) -> - assert (arity = List.length tys); - (* Generate the field values *) - let ctx, see = - compute_expanded_symbolic_tuple_value ended_regions tys ctx - in - (* Apply in the context *) - let ctx = - apply_symbolic_expansion_non_borrow config original_sv see ctx - in - (* Update the synthesized program *) - S.synthesize_symbolic_expansion_no_branching original_sv see; - (* Return *) - ctx - (* Boxes *) - | DerefBox, T.Adt (T.Assumed T.Box, [], [ boxed_ty ]) -> - let ctx, see = - compute_expanded_symbolic_box_value ended_regions boxed_ty ctx - in - (* Apply in the context *) - let ctx = - apply_symbolic_expansion_non_borrow config original_sv see ctx - in - (* Update the synthesized program *) - S.synthesize_symbolic_expansion_no_branching original_sv see; - (* Return *) - ctx - (* Borrows *) - | Deref, T.Ref (region, ref_ty, rkind) -> - expand_symbolic_value_borrow config original_sv ended_regions region - ref_ty rkind ctx - | _ -> - failwith - ("Unreachable: " ^ E.show_projection_elem pe ^ ", " ^ T.show_rty rty) - in - (* Sanity check: the symbolic value has disappeared *) - assert (not (symbolic_value_id_in_ctx original_sv.V.sv_id ctx)); - (* Return *) - ctx - -(** Expand a symbolic enumeration value. - - This might lead to branching. - *) -let expand_symbolic_enum_value (config : C.config) (sp : V.symbolic_proj_comp) - (ctx : C.eval_ctx) : C.eval_ctx list = - (* Compute the expanded value - note that when doing so, we may introduce - * fresh symbolic values in the context (which thus gets updated) *) - let original_sv = sp.V.svalue in - let rty = original_sv.V.sv_ty in - let ended_regions = sp.V.rset_ended in - match rty with - (* The value should be a "regular" ADTs *) - | T.Adt (T.AdtId def_id, regions, types) -> - (* Compute the expanded value - there should be exactly one because we - * don't allow to expand enumerations with strictly more than one variant *) - let expand_enumerations = true in - let res = - compute_expanded_symbolic_adt_value expand_enumerations ended_regions - def_id regions types ctx - in - (* Update the synthesized program *) - let seel = List.map (fun (_, x) -> x) res in - S.synthesize_symbolic_expansion_enum_branching original_sv seel; - (* Apply in the context *) - let apply (ctx, see) : C.eval_ctx = - let ctx = - apply_symbolic_expansion_non_borrow config original_sv see ctx - in - (* Sanity check: the symbolic value has disappeared *) - assert (not (symbolic_value_id_in_ctx original_sv.V.sv_id ctx)); - (* Return *) - ctx - in - List.map apply res - | _ -> failwith "Unexpected" - (** Update the environment to be able to read a place. When reading a place, we may be stuck along the way because some value @@ -1209,21 +742,6 @@ let rec drop_borrows_loans_at_lplace (config : C.config) (p : E.place) ctx with UpdateCtx ctx -> drop_borrows_loans_at_lplace config p ctx) -(** Return true if a type is "primitively copyable". - * - * "primitively copyable" means that copying instances of this type doesn't - * require calling dedicated functions defined through the Copy trait. It - * is the case for types like integers, shared borrows, etc. - *) -let rec type_is_primitively_copyable (ty : T.ety) : bool = - match ty with - | T.Adt ((T.AdtId _ | T.Assumed _), _, _) -> false - | T.Adt (T.Tuple, _, tys) -> List.for_all type_is_primitively_copyable tys - | T.TypeVar _ | T.Never | T.Str | T.Array _ | T.Slice _ -> false - | T.Bool | T.Char | T.Integer _ -> true - | T.Ref (_, _, T.Mut) -> false - | T.Ref (_, _, T.Shared) -> true - (** Copy a value, and return the resulting value. Note that copying values might update the context. For instance, when diff --git a/src/InterpreterExpansion.ml b/src/InterpreterExpansion.ml new file mode 100644 index 00000000..7b249717 --- /dev/null +++ b/src/InterpreterExpansion.ml @@ -0,0 +1,490 @@ +(* This module provides the functions which handle expansion of symbolic values. + * For now, this file doesn't handle expansion of ⊥ values because they need + * some path utilities for replacement. We might change that in the future (by + * using indices to identify the values for instance). *) + +module T = Types +module V = Values +open Scalars +module E = Expressions +open Errors +module C = Contexts +module Subst = Substitute +module A = CfimAst +module L = Logging +open TypesUtils +open ValuesUtils +module Inv = Invariants +module S = Synthesis +open Utils +open InterpreterUtils +open InterpreterProjectors +open InterpreterBorrows + +(** Projector kind *) +type proj_kind = LoanProj | BorrowProj + +(** Auxiliary function. + Apply a symbolic expansion to avalues in a context, targetting a specific + kind of projectors. + + [proj_kind] controls whether we apply the expansion to projectors + on loans or projectors on borrows. + + When dealing with reference expansion, it is necessary to first apply the + expansion on loan projectors, then on borrow projectors. The reason is + that reducing the borrow projectors might require to perform some reborrows, + in which case we need to lookup the corresponding loans in the context. + + [allow_reborrows] controls whether we allow reborrows or not. It is useful + only if we target borrow projectors. + + Also, if this function is called on an expansion for *shared references*, + the proj borrows should already have been expanded. + + TODO: the way this function is used is a bit complex, especially because of + the above condition. Maybe we should have: + 1. a generic function to expand the loan projectors + 2. a function to expand the borrow projectors for non-borrows + 3. specialized functions for mut borrows and shared borrows + Note that 2. and 3. may have a little bit of duplicated code, but hopefully + it would make things clearer. +*) +let apply_symbolic_expansion_to_target_avalues (config : C.config) + (allow_reborrows : bool) (proj_kind : proj_kind) + (original_sv : V.symbolic_value) (expansion : symbolic_expansion) + (ctx : C.eval_ctx) : C.eval_ctx = + (* Symbolic values contained in the expansion might contain already ended regions *) + let check_symbolic_no_ended = false in + (* Prepare reborrows registration *) + let fresh_reborrow, apply_registered_reborrows = + prepare_reborrows config allow_reborrows ctx + in + (* Visitor to apply the expansion *) + let obj = + object + inherit [_] C.map_eval_ctx as super + + method! visit_abs proj_regions abs = + assert (Option.is_none proj_regions); + let proj_regions = Some abs.V.regions in + super#visit_abs proj_regions abs + (** When visiting an abstraction, we remember the regions it owns to be + able to properly reduce projectors when expanding symbolic values *) + + method! visit_ASymbolic proj_regions aproj = + let proj_regions = Option.get proj_regions in + match (aproj, proj_kind) with + | V.AProjLoans sv, LoanProj -> + (* Check if this is the symbolic value we are looking for *) + if same_symbolic_id sv original_sv then + (* Apply the projector *) + let projected_value = + apply_proj_loans_on_symbolic_expansion proj_regions expansion + original_sv.V.sv_ty + in + (* Replace *) + projected_value.V.value + else + (* Not the searched symbolic value: nothing to do *) + super#visit_ASymbolic (Some proj_regions) aproj + | V.AProjBorrows (sv, proj_ty), BorrowProj -> + (* Check if this is the symbolic value we are looking for *) + if same_symbolic_id sv original_sv then + (* Convert the symbolic expansion to a value on which we can + * apply a projector (if the expansion is a reference expansion, + * convert it to a borrow) *) + (* WARNING: we mustn't get there if the expansion is for a shared + * reference. *) + let expansion = + symbolic_expansion_non_shared_borrow_to_value original_sv + expansion + in + (* Apply the projector *) + let projected_value = + apply_proj_borrows check_symbolic_no_ended ctx fresh_reborrow + proj_regions expansion proj_ty + in + (* Replace *) + projected_value.V.value + else + (* Not the searched symbolic value: nothing to do *) + super#visit_ASymbolic (Some proj_regions) aproj + | V.AProjLoans _, BorrowProj | V.AProjBorrows (_, _), LoanProj -> + (* Nothing to do *) + super#visit_ASymbolic (Some proj_regions) aproj + end + in + (* Apply the expansion *) + let ctx = obj#visit_eval_ctx None ctx in + (* Apply the reborrows *) + apply_registered_reborrows ctx + +(** Auxiliary function. + Apply a symbolic expansion to avalues in a context. +*) +let apply_symbolic_expansion_to_avalues (config : C.config) + (allow_reborrows : bool) (original_sv : V.symbolic_value) + (expansion : symbolic_expansion) (ctx : C.eval_ctx) : C.eval_ctx = + let apply_expansion proj_kind ctx = + apply_symbolic_expansion_to_target_avalues config allow_reborrows proj_kind + original_sv expansion ctx + in + (* First target the loan projectors, then the borrow projectors *) + let ctx = apply_expansion LoanProj ctx in + let ctx = apply_expansion BorrowProj ctx in + ctx + +(** Auxiliary function. + + Simply replace the symbolic values (*not avalues*) in the context with + a given value. Will break invariants if not used properly. +*) +let replace_symbolic_values (at_most_once : bool) + (original_sv : V.symbolic_value) (nv : V.value) (ctx : C.eval_ctx) : + C.eval_ctx = + (* Count *) + let replaced = ref false in + let replace () = + if at_most_once then assert (not !replaced); + replaced := true; + nv + in + (* Visitor to apply the substitution *) + let obj = + object + inherit [_] C.map_eval_ctx as super + + method! visit_Symbolic env spc = + if same_symbolic_id spc.V.svalue original_sv then replace () + else super#visit_Symbolic env spc + end + in + (* Apply the substitution *) + let ctx = obj#visit_eval_ctx None ctx in + (* Check that we substituted *) + assert !replaced; + (* Return *) + ctx + +(** Apply a symbolic expansion to a context, by replacing the original + symbolic value with its expanded value. Is valid only if the expansion + is not a borrow (i.e., an adt...). +*) +let apply_symbolic_expansion_non_borrow (config : C.config) + (original_sv : V.symbolic_value) (expansion : symbolic_expansion) + (ctx : C.eval_ctx) : C.eval_ctx = + (* Apply the expansion to non-abstraction values *) + let nv = symbolic_expansion_non_borrow_to_value original_sv expansion in + let at_most_once = false in + let ctx = replace_symbolic_values at_most_once original_sv nv.V.value ctx in + (* Apply the expansion to abstraction values *) + let allow_reborrows = false in + apply_symbolic_expansion_to_avalues config allow_reborrows original_sv + expansion ctx + +(** Compute the expansion of an adt value. + + The function might return a list of contexts and values if the symbolic + value to expand is an enumeration. + + `expand_enumerations` controls the expansion of enumerations: if false, it + doesn't allow the expansion of enumerations *containing several variants*. + *) +let compute_expanded_symbolic_adt_value (expand_enumerations : bool) + (ended_regions : T.RegionId.set_t) (def_id : T.TypeDefId.id) + (regions : T.RegionId.id T.region list) (types : T.rty list) + (ctx : C.eval_ctx) : (C.eval_ctx * symbolic_expansion) list = + (* Lookup the definition and check if it is an enumeration with several + * variants *) + let def = C.ctx_lookup_type_def ctx def_id in + assert (List.length regions = List.length def.T.region_params); + (* Retrieve, for every variant, the list of its instantiated field types *) + let variants_fields_types = + Subst.type_def_get_instantiated_variants_fields_rtypes def regions types + in + (* Check if there is strictly more than one variant *) + if List.length variants_fields_types > 1 && not expand_enumerations then + failwith "Not allowed to expand enumerations with several variants"; + (* Initialize the expanded value for a given variant *) + let initialize (ctx : C.eval_ctx) + ((variant_id, field_types) : T.VariantId.id option * T.rty list) : + C.eval_ctx * symbolic_expansion = + let ctx, field_values = + List.fold_left_map + (fun ctx (ty : T.rty) -> + mk_fresh_symbolic_proj_comp ended_regions ty ctx) + ctx field_types + in + let see = SeAdt (variant_id, field_values) in + (ctx, see) + in + (* Initialize all the expanded values of all the variants *) + List.map (initialize ctx) variants_fields_types + +let compute_expanded_symbolic_tuple_value (ended_regions : T.RegionId.set_t) + (field_types : T.rty list) (ctx : C.eval_ctx) : + C.eval_ctx * symbolic_expansion = + (* Generate the field values *) + let ctx, field_values = + List.fold_left_map + (fun ctx sv_ty -> mk_fresh_symbolic_proj_comp ended_regions sv_ty ctx) + ctx field_types + in + let variant_id = None in + let see = SeAdt (variant_id, field_values) in + (ctx, see) + +let compute_expanded_symbolic_box_value (ended_regions : T.RegionId.set_t) + (boxed_ty : T.rty) (ctx : C.eval_ctx) : C.eval_ctx * symbolic_expansion = + (* Introduce a fresh symbolic value *) + let ctx, boxed_value = + mk_fresh_symbolic_proj_comp ended_regions boxed_ty ctx + in + let see = SeAdt (None, [ boxed_value ]) in + (ctx, see) + +let expand_symbolic_value_shared_borrow (config : C.config) + (original_sv : V.symbolic_value) (ended_regions : T.RegionId.set_t) + (ref_ty : T.rty) (ctx : C.eval_ctx) : C.eval_ctx = + (* First, replace the projectors on borrows (AProjBorrow and proj_comp) + * The important point is that the symbolic value to expand may appear + * several times, if it has been copied. In this case, we need to introduce + * one fresh borrow id per instance. + *) + let borrows = ref V.BorrowId.Set.empty in + let borrow_counter = ref ctx.C.borrow_counter in + let fresh_borrow () = + let bid', cnt' = V.BorrowId.fresh !borrow_counter in + borrow_counter := cnt'; + borrows := V.BorrowId.Set.add bid' !borrows; + bid' + in + (* Small utility used on shared borrows in abstractions (regular borrow + * projector and asb). + * Returns `Some` if the symbolic value has been expanded to an asb list, + * `None` otherwise *) + let reborrow_ashared proj_regions (sv : V.symbolic_value) (proj_ty : T.rty) : + V.abstract_shared_borrows option = + if same_symbolic_id sv original_sv then + match proj_ty with + | T.Ref (r, ref_ty, T.Shared) -> + (* Projector over the shared value *) + let shared_asb = V.AsbProjReborrows (sv, ref_ty) in + (* Check if the region is in the set of projected regions *) + if region_in_set r proj_regions then + (* In the set: we need to reborrow *) + let bid = fresh_borrow () in + Some [ V.AsbBorrow bid; shared_asb ] + else (* Not in the set: ignore *) + Some [ shared_asb ] + | _ -> failwith "Unexpected" + else None + in + (* Visitor to replace the projectors on borrows *) + let obj = + object + inherit [_] C.map_eval_ctx as super + + method! visit_Symbolic env sv = + if same_symbolic_id sv.V.svalue original_sv then + let bid = fresh_borrow () in + V.Borrow (V.SharedBorrow bid) + else super#visit_Symbolic env sv + + method! visit_Abs proj_regions abs = + assert (Option.is_none proj_regions); + let proj_regions = Some abs.V.regions in + super#visit_Abs proj_regions abs + + method! visit_AProjSharedBorrow proj_regions asb = + let expand_asb (asb : V.abstract_shared_borrow) : + V.abstract_shared_borrows = + match asb with + | V.AsbBorrow _ -> [ asb ] + | V.AsbProjReborrows (sv, proj_ty) -> ( + match reborrow_ashared (Option.get proj_regions) sv proj_ty with + | None -> [ asb ] + | Some asb -> asb) + in + let asb = List.concat (List.map expand_asb asb) in + V.AProjSharedBorrow asb + + method! visit_ASymbolic proj_regions aproj = + match aproj with + | AProjLoans _ -> + (* Loans are handled later *) + super#visit_ASymbolic proj_regions aproj + | AProjBorrows (sv, proj_ty) -> ( + (* Check if we need to reborrow *) + match reborrow_ashared (Option.get proj_regions) sv proj_ty with + | None -> super#visit_ASymbolic proj_regions aproj + | Some asb -> V.ABorrow (V.AProjSharedBorrow asb)) + end + in + (* Call the visitor *) + let ctx = obj#visit_eval_ctx None ctx in + let ctx = { ctx with C.borrow_counter = !borrow_counter } in + (* Finally, replace the projectors on loans *) + let bids = !borrows in + assert (not (V.BorrowId.Set.is_empty bids)); + let ctx, shared_sv = mk_fresh_symbolic_proj_comp ended_regions ref_ty ctx in + let see = SeSharedRef (bids, shared_sv) in + let allow_reborrows = true in + let ctx = + apply_symbolic_expansion_to_avalues config allow_reborrows original_sv see + ctx + in + (* Update the synthesized program *) + S.synthesize_symbolic_expansion_no_branching original_sv see; + (* Return *) + ctx + +let expand_symbolic_value_borrow (config : C.config) + (original_sv : V.symbolic_value) (ended_regions : T.RegionId.set_t) + (region : T.RegionId.id T.region) (ref_ty : T.rty) (rkind : T.ref_kind) + (ctx : C.eval_ctx) : C.eval_ctx = + (* Check that we are allowed to expand the reference *) + assert (not (region_in_set region ended_regions)); + (* Match on the reference kind *) + match rkind with + | T.Mut -> + (* Simple case: simply create a fresh symbolic value and a fresh + * borrow id *) + let ctx, sv = mk_fresh_symbolic_proj_comp ended_regions ref_ty ctx in + let ctx, bid = C.fresh_borrow_id ctx in + let see = SeMutRef (bid, sv) in + (* Expand the symbolic values - we simply perform a substitution (and + * check that we perform exactly one substitution) *) + let nv = symbolic_expansion_non_shared_borrow_to_value original_sv see in + let at_most_once = true in + let ctx = + replace_symbolic_values at_most_once original_sv nv.V.value ctx + in + (* Expand the symbolic avalues *) + let allow_reborrows = true in + let ctx = + apply_symbolic_expansion_to_avalues config allow_reborrows original_sv + see ctx + in + (* Update the synthesized program *) + S.synthesize_symbolic_expansion_no_branching original_sv see; + (* Return *) + ctx + | T.Shared -> + expand_symbolic_value_shared_borrow config original_sv ended_regions + ref_ty ctx + +(** Expand a symbolic value which is not an enumeration with several variants + (i.e., in a situation where it doesn't lead to branching). + + This function is used when exploring paths. + *) +let expand_symbolic_value_no_branching (config : C.config) + (pe : E.projection_elem) (sp : V.symbolic_proj_comp) (ctx : C.eval_ctx) : + C.eval_ctx = + (* Compute the expanded value - note that when doing so, we may introduce + * fresh symbolic values in the context (which thus gets updated) *) + let original_sv = sp.V.svalue in + let rty = original_sv.V.sv_ty in + let ended_regions = sp.V.rset_ended in + let ctx = + match (pe, rty) with + (* "Regular" ADTs *) + | ( Field (ProjAdt (def_id, _opt_variant_id), _), + T.Adt (T.AdtId def_id', regions, types) ) -> ( + assert (def_id = def_id'); + (* Compute the expanded value - there should be exactly one because we + * don't allow to expand enumerations with strictly more than one variant *) + let expand_enumerations = false in + match + compute_expanded_symbolic_adt_value expand_enumerations ended_regions + def_id regions types ctx + with + | [ (ctx, see) ] -> + (* Apply in the context *) + let ctx = + apply_symbolic_expansion_non_borrow config original_sv see ctx + in + (* Update the synthesized program *) + S.synthesize_symbolic_expansion_no_branching original_sv see; + (* Return *) + ctx + | _ -> failwith "Unexpected") + (* Tuples *) + | Field (ProjTuple arity, _), T.Adt (T.Tuple, [], tys) -> + assert (arity = List.length tys); + (* Generate the field values *) + let ctx, see = + compute_expanded_symbolic_tuple_value ended_regions tys ctx + in + (* Apply in the context *) + let ctx = + apply_symbolic_expansion_non_borrow config original_sv see ctx + in + (* Update the synthesized program *) + S.synthesize_symbolic_expansion_no_branching original_sv see; + (* Return *) + ctx + (* Boxes *) + | DerefBox, T.Adt (T.Assumed T.Box, [], [ boxed_ty ]) -> + let ctx, see = + compute_expanded_symbolic_box_value ended_regions boxed_ty ctx + in + (* Apply in the context *) + let ctx = + apply_symbolic_expansion_non_borrow config original_sv see ctx + in + (* Update the synthesized program *) + S.synthesize_symbolic_expansion_no_branching original_sv see; + (* Return *) + ctx + (* Borrows *) + | Deref, T.Ref (region, ref_ty, rkind) -> + expand_symbolic_value_borrow config original_sv ended_regions region + ref_ty rkind ctx + | _ -> + failwith + ("Unreachable: " ^ E.show_projection_elem pe ^ ", " ^ T.show_rty rty) + in + (* Sanity check: the symbolic value has disappeared *) + assert (not (symbolic_value_id_in_ctx original_sv.V.sv_id ctx)); + (* Return *) + ctx + +(** Expand a symbolic enumeration value. + + This might lead to branching. + *) +let expand_symbolic_enum_value (config : C.config) (sp : V.symbolic_proj_comp) + (ctx : C.eval_ctx) : C.eval_ctx list = + (* Compute the expanded value - note that when doing so, we may introduce + * fresh symbolic values in the context (which thus gets updated) *) + let original_sv = sp.V.svalue in + let rty = original_sv.V.sv_ty in + let ended_regions = sp.V.rset_ended in + match rty with + (* The value should be a "regular" ADTs *) + | T.Adt (T.AdtId def_id, regions, types) -> + (* Compute the expanded value - there should be exactly one because we + * don't allow to expand enumerations with strictly more than one variant *) + let expand_enumerations = true in + let res = + compute_expanded_symbolic_adt_value expand_enumerations ended_regions + def_id regions types ctx + in + (* Update the synthesized program *) + let seel = List.map (fun (_, x) -> x) res in + S.synthesize_symbolic_expansion_enum_branching original_sv seel; + (* Apply in the context *) + let apply (ctx, see) : C.eval_ctx = + let ctx = + apply_symbolic_expansion_non_borrow config original_sv see ctx + in + (* Sanity check: the symbolic value has disappeared *) + assert (not (symbolic_value_id_in_ctx original_sv.V.sv_id ctx)); + (* Return *) + ctx + in + List.map apply res + | _ -> failwith "Unexpected" diff --git a/src/InterpreterUtils.ml b/src/InterpreterUtils.ml index c652a1d3..dc5a0477 100644 --- a/src/InterpreterUtils.ml +++ b/src/InterpreterUtils.ml @@ -1,3 +1,5 @@ +(* TODO: most of the definitions in this file need to be moved elsewhere *) + module T = Types module V = Values open Scalars @@ -792,3 +794,18 @@ type outer_borrows_or_abs = exception FoundOuter of outer_borrows_or_abs (** Utility exception *) + +(** Return true if a type is "primitively copyable". + * + * "primitively copyable" means that copying instances of this type doesn't + * require calling dedicated functions defined through the Copy trait. It + * is the case for types like integers, shared borrows, etc. + *) +let rec type_is_primitively_copyable (ty : T.ety) : bool = + match ty with + | T.Adt ((T.AdtId _ | T.Assumed _), _, _) -> false + | T.Adt (T.Tuple, _, tys) -> List.for_all type_is_primitively_copyable tys + | T.TypeVar _ | T.Never | T.Str | T.Array _ | T.Slice _ -> false + | T.Bool | T.Char | T.Integer _ -> true + | T.Ref (_, _, T.Mut) -> false + | T.Ref (_, _, T.Shared) -> true -- cgit v1.2.3 From a48b5f36738fb86026f618fed4190a2d8b5ab08e Mon Sep 17 00:00:00 2001 From: Son Ho Date: Thu, 6 Jan 2022 10:36:07 +0100 Subject: Move some definitions from Interpreter to InterpreterPaths --- src/Interpreter.ml | 816 +---------------------------------------------- src/InterpreterPaths.ml | 833 ++++++++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 834 insertions(+), 815 deletions(-) create mode 100644 src/InterpreterPaths.ml (limited to 'src') diff --git a/src/Interpreter.ml b/src/Interpreter.ml index d8256186..4ca7d58f 100644 --- a/src/Interpreter.ml +++ b/src/Interpreter.ml @@ -16,6 +16,7 @@ open InterpreterUtils open InterpreterProjectors open InterpreterBorrows open InterpreterExpansion +open InterpreterPaths (* TODO: check that the value types are correct when evaluating *) (* TODO: for debugging purposes, we might want to put use eval_ctx everywhere @@ -37,777 +38,6 @@ type eval_error = Panic type 'a eval_result = ('a, eval_error) result -(** Paths *) - -(** When we fail reading from or writing to a path, it might be because we - need to update the environment by ending borrows, expanding symbolic - values, etc. The following type is used to convey this information. - - TODO: compare with borrow_lres? -*) -type path_fail_kind = - | FailSharedLoan of V.BorrowId.Set.t - (** Failure because we couldn't go inside a shared loan *) - | FailMutLoan of V.BorrowId.id - (** Failure because we couldn't go inside a mutable loan *) - | FailInactivatedMutBorrow of V.BorrowId.id - (** Failure because we couldn't go inside an inactivated mutable borrow - (which should get activated) *) - | FailSymbolic of (E.projection_elem * V.symbolic_proj_comp) - (** Failure because we need to enter a symbolic value (and thus need to expand it) *) - (* TODO: Remove the parentheses *) - | FailBottom of (int * E.projection_elem * T.ety) - (** Failure because we need to enter an any value - we can expand Bottom - values if they are left values. We return the number of elements which - were remaining in the path when we reached the error - this allows to - properly update the Bottom value, if needs be. - *) - | FailBorrow of V.borrow_content - (** We got stuck because we couldn't enter a borrow *) - -(** Result of evaluating a path (reading from a path/writing to a path) - - Note that when we fail, we return information used to update the - environment, as well as the -*) -type 'a path_access_result = ('a, path_fail_kind) result -(** The result of reading from/writing to a place *) - -type updated_read_value = { read : V.typed_value; updated : V.typed_value } - -type projection_access = { - enter_shared_loans : bool; - enter_mut_borrows : bool; - lookup_shared_borrows : bool; -} - -(** Generic function to access (read/write) the value at the end of a projection. - - We return the (eventually) updated value, the value we read at the end of - the place and the (eventually) updated environment. - - TODO: use exceptions? - *) -let rec access_projection (access : projection_access) (ctx : C.eval_ctx) - (* Function to (eventually) update the value we find *) - (update : V.typed_value -> V.typed_value) (p : E.projection) - (v : V.typed_value) : (C.eval_ctx * updated_read_value) path_access_result = - (* For looking up/updating shared loans *) - let ek : exploration_kind = - { enter_shared_loans = true; enter_mut_borrows = true; enter_abs = true } - in - match p with - | [] -> - let nv = update v in - (* Type checking *) - if nv.ty <> v.ty then ( - L.log#lerror - (lazy - ("Not the same type:\n- nv.ty: " ^ T.show_ety nv.ty ^ "\n- v.ty: " - ^ T.show_ety v.ty)); - failwith - "Assertion failed: new value doesn't have the same type as its \ - destination"); - Ok (ctx, { read = v; updated = nv }) - | pe :: p' -> ( - (* Match on the projection element and the value *) - match (pe, v.V.value, v.V.ty) with - (* Field projection - ADTs *) - | ( Field (ProjAdt (def_id, opt_variant_id), field_id), - V.Adt adt, - T.Adt (T.AdtId def_id', _, _) ) -> ( - assert (def_id = def_id'); - (* Check that the projection is consistent with the current value *) - (match (opt_variant_id, adt.variant_id) with - | None, None -> () - | Some vid, Some vid' -> if vid <> vid' then failwith "Unreachable" - | _ -> failwith "Unreachable"); - (* Actually project *) - let fv = T.FieldId.nth adt.field_values field_id in - match access_projection access ctx update p' fv with - | Error err -> Error err - | Ok (ctx, res) -> - (* Update the field value *) - let nvalues = - T.FieldId.update_nth adt.field_values field_id res.updated - in - let nadt = V.Adt { adt with V.field_values = nvalues } in - let updated = { v with value = nadt } in - Ok (ctx, { res with updated })) - (* Tuples *) - | Field (ProjTuple arity, field_id), V.Adt adt, T.Adt (T.Tuple, _, _) -> ( - assert (arity = List.length adt.field_values); - let fv = T.FieldId.nth adt.field_values field_id in - (* Project *) - match access_projection access ctx update p' fv with - | Error err -> Error err - | Ok (ctx, res) -> - (* Update the field value *) - let nvalues = - T.FieldId.update_nth adt.field_values field_id res.updated - in - let ntuple = V.Adt { adt with field_values = nvalues } in - let updated = { v with value = ntuple } in - Ok (ctx, { res with updated }) - (* If we reach Bottom, it may mean we need to expand an uninitialized - * enumeration value *)) - | Field (ProjAdt (_, _), _), V.Bottom, _ -> - Error (FailBottom (1 + List.length p', pe, v.ty)) - | Field (ProjTuple _, _), V.Bottom, _ -> - Error (FailBottom (1 + List.length p', pe, v.ty)) - (* Symbolic value: needs to be expanded *) - | _, Symbolic sp, _ -> - (* Expand the symbolic value *) - Error (FailSymbolic (pe, sp)) - (* Box dereferencement *) - | ( DerefBox, - Adt { variant_id = None; field_values = [ bv ] }, - T.Adt (T.Assumed T.Box, _, _) ) -> ( - (* We allow moving inside of boxes. In practice, this kind of - * manipulations should happen only inside unsage code, so - * it shouldn't happen due to user code, and we leverage it - * when implementing box dereferencement for the concrete - * interpreter *) - match access_projection access ctx update p' bv with - | Error err -> Error err - | Ok (ctx, res) -> - let nv = - { - v with - value = - V.Adt { variant_id = None; field_values = [ res.updated ] }; - } - in - Ok (ctx, { res with updated = nv })) - (* Borrows *) - | Deref, V.Borrow bc, _ -> ( - match bc with - | V.SharedBorrow bid -> - (* Lookup the loan content, and explore from there *) - if access.lookup_shared_borrows then - match lookup_loan ek bid ctx with - | _, Concrete (V.MutLoan _) -> failwith "Expected a shared loan" - | _, Concrete (V.SharedLoan (bids, sv)) -> ( - (* Explore the shared value *) - match access_projection access ctx update p' sv with - | Error err -> Error err - | Ok (ctx, res) -> - (* Update the shared loan with the new value returned - by [access_projection] *) - let ctx = - update_loan ek bid - (V.SharedLoan (bids, res.updated)) - ctx - in - (* Return - note that we don't need to update the borrow itself *) - Ok (ctx, { res with updated = v })) - | ( _, - Abstract - ( V.AMutLoan (_, _) - | V.AEndedMutLoan { given_back = _; child = _ } - | V.AEndedSharedLoan (_, _) - | V.AIgnoredMutLoan (_, _) - | V.AEndedIgnoredMutLoan { given_back = _; child = _ } - | V.AIgnoredSharedLoan _ ) ) -> - failwith "Expected a shared (abstraction) loan" - | _, Abstract (V.ASharedLoan (bids, sv, _av)) -> ( - (* Explore the shared value *) - match access_projection access ctx update p' sv with - | Error err -> Error err - | Ok (ctx, res) -> - (* Relookup the child avalue *) - let av = - match lookup_loan ek bid ctx with - | _, Abstract (V.ASharedLoan (_, _, av)) -> av - | _ -> failwith "Unexpected" - in - (* Update the shared loan with the new value returned - by [access_projection] *) - let ctx = - update_aloan ek bid - (V.ASharedLoan (bids, res.updated, av)) - ctx - in - (* Return - note that we don't need to update the borrow itself *) - Ok (ctx, { res with updated = v })) - else Error (FailBorrow bc) - | V.InactivatedMutBorrow bid -> Error (FailInactivatedMutBorrow bid) - | V.MutBorrow (bid, bv) -> - if access.enter_mut_borrows then - match access_projection access ctx update p' bv with - | Error err -> Error err - | Ok (ctx, res) -> - let nv = - { - v with - value = V.Borrow (V.MutBorrow (bid, res.updated)); - } - in - Ok (ctx, { res with updated = nv }) - else Error (FailBorrow bc)) - | _, V.Loan lc, _ -> ( - match lc with - | V.MutLoan bid -> Error (FailMutLoan bid) - | V.SharedLoan (bids, sv) -> - (* If we can enter shared loan, we ignore the loan. Pay attention - to the fact that we need to reexplore the *whole* place (i.e, - we mustn't ignore the current projection element *) - if access.enter_shared_loans then - match access_projection access ctx update (pe :: p') sv with - | Error err -> Error err - | Ok (ctx, res) -> - let nv = - { - v with - value = V.Loan (V.SharedLoan (bids, res.updated)); - } - in - Ok (ctx, { res with updated = nv }) - else Error (FailSharedLoan bids)) - | (_, (V.Concrete _ | V.Adt _ | V.Bottom | V.Borrow _), _) as r -> - let pe, v, ty = r in - let pe = "- pe: " ^ E.show_projection_elem pe in - let v = "- v:\n" ^ V.show_value v in - let ty = "- ty:\n" ^ T.show_ety ty in - L.log#serror ("Inconsistent projection:\n" ^ pe ^ "\n" ^ v ^ "\n" ^ ty); - failwith "Inconsistent projection") - -(** Generic function to access (read/write) the value at a given place. - - We return the value we read at the place and the (eventually) updated - environment, if we managed to access the place, or the precise reason - why we failed. - *) -let access_place (access : projection_access) - (* Function to (eventually) update the value we find *) - (update : V.typed_value -> V.typed_value) (p : E.place) (ctx : C.eval_ctx) - : (C.eval_ctx * V.typed_value) path_access_result = - (* Lookup the variable's value *) - let value = C.ctx_lookup_var_value ctx p.var_id in - (* Apply the projection *) - match access_projection access ctx update p.projection value with - | Error err -> Error err - | Ok (ctx, res) -> - (* Update the value *) - let ctx = C.ctx_update_var_value ctx p.var_id res.updated in - (* Return *) - Ok (ctx, res.read) - -type access_kind = - | Read (** We can go inside borrows and loans *) - | Write (** Don't enter shared borrows or shared loans *) - | Move (** Don't enter borrows or loans *) - -let access_kind_to_projection_access (access : access_kind) : projection_access - = - match access with - | Read -> - { - enter_shared_loans = true; - enter_mut_borrows = true; - lookup_shared_borrows = true; - } - | Write -> - { - enter_shared_loans = false; - enter_mut_borrows = true; - lookup_shared_borrows = false; - } - | Move -> - { - enter_shared_loans = false; - enter_mut_borrows = false; - lookup_shared_borrows = false; - } - -(** Read the value at a given place *) -let read_place (config : C.config) (access : access_kind) (p : E.place) - (ctx : C.eval_ctx) : V.typed_value path_access_result = - let access = access_kind_to_projection_access access in - (* The update function is the identity *) - let update v = v in - match access_place access update p ctx with - | Error err -> Error err - | Ok (ctx1, read_value) -> - (* Note that we ignore the new environment: it should be the same as the - original one. - *) - if config.check_invariants then - if ctx1 <> ctx then ( - let msg = - "Unexpected environment update:\nNew environment:\n" - ^ C.show_env ctx1.env ^ "\n\nOld environment:\n" - ^ C.show_env ctx.env - in - L.log#serror msg; - failwith "Unexpected environment update"); - Ok read_value - -let read_place_unwrap (config : C.config) (access : access_kind) (p : E.place) - (ctx : C.eval_ctx) : V.typed_value = - match read_place config access p ctx with - | Error _ -> failwith "Unreachable" - | Ok v -> v - -(** Update the value at a given place *) -let write_place (_config : C.config) (access : access_kind) (p : E.place) - (nv : V.typed_value) (ctx : C.eval_ctx) : C.eval_ctx path_access_result = - let access = access_kind_to_projection_access access in - (* The update function substitutes the value with the new value *) - let update _ = nv in - match access_place access update p ctx with - | Error err -> Error err - | Ok (ctx, _) -> - (* We ignore the read value *) - Ok ctx - -let write_place_unwrap (config : C.config) (access : access_kind) (p : E.place) - (nv : V.typed_value) (ctx : C.eval_ctx) : C.eval_ctx = - match write_place config access p nv ctx with - | Error _ -> failwith "Unreachable" - | Ok ctx -> ctx - -(** Compute an expanded ADT bottom value *) -let compute_expanded_bottom_adt_value (tyctx : T.type_def list) - (def_id : T.TypeDefId.id) (opt_variant_id : T.VariantId.id option) - (regions : T.erased_region list) (types : T.ety list) : V.typed_value = - (* Lookup the definition and check if it is an enumeration - it - should be an enumeration if and only if the projection element - is a field projection with *some* variant id. Retrieve the list - of fields at the same time. *) - let def = T.TypeDefId.nth tyctx def_id in - assert (List.length regions = List.length def.T.region_params); - (* Compute the field types *) - let field_types = - Subst.type_def_get_instantiated_field_etypes def opt_variant_id types - in - (* Initialize the expanded value *) - let fields = - List.map - (fun ty : V.typed_value -> ({ V.value = V.Bottom; ty } : V.typed_value)) - field_types - in - let av = V.Adt { variant_id = opt_variant_id; field_values = fields } in - let ty = T.Adt (T.AdtId def_id, regions, types) in - { V.value = av; V.ty } - -(** Compute an expanded tuple bottom value *) -let compute_expanded_bottom_tuple_value (field_types : T.ety list) : - V.typed_value = - (* Generate the field values *) - let fields = - List.map (fun ty : V.typed_value -> { V.value = Bottom; ty }) field_types - in - let v = V.Adt { variant_id = None; field_values = fields } in - let ty = T.Adt (T.Tuple, [], field_types) in - { V.value = v; V.ty } - -(** Auxiliary helper to expand [Bottom] values. - - During compilation, rustc desaggregates the ADT initializations. The - consequence is that the following rust code: - ``` - let x = Cons a b; - ``` - - Looks like this in MIR: - ``` - (x as Cons).0 = a; - (x as Cons).1 = b; - set_discriminant(x, 0); // If `Cons` is the variant of index 0 - ``` - - The consequence is that we may sometimes need to write fields to values - which are currently [Bottom]. When doing this, we first expand the value - to, say, [Cons Bottom Bottom] (note that field projection contains information - about which variant we should project to, which is why we *can* set the - variant index when writing one of its fields). -*) -let expand_bottom_value_from_projection (config : C.config) - (access : access_kind) (p : E.place) (remaining_pes : int) - (pe : E.projection_elem) (ty : T.ety) (ctx : C.eval_ctx) : C.eval_ctx = - (* Debugging *) - L.log#ldebug - (lazy - ("expand_bottom_value_from_projection:\n" ^ "pe: " - ^ E.show_projection_elem pe ^ "\n" ^ "ty: " ^ T.show_ety ty)); - (* Prepare the update: we need to take the proper prefix of the place - during whose evaluation we got stuck *) - let projection' = - fst - (Utilities.list_split_at p.projection - (List.length p.projection - remaining_pes)) - in - let p' = { p with projection = projection' } in - (* Compute the expanded value. - The type of the [Bottom] value should be a tuple or an ADT. - Note that the projection element we got stuck at should be a - field projection, and gives the variant id if the [Bottom] value - is an enumeration value. - Also, the expanded value should be the proper ADT variant or a tuple - with the proper arity, with all the fields initialized to [Bottom] - *) - let nv = - match (pe, ty) with - (* "Regular" ADTs *) - | ( Field (ProjAdt (def_id, opt_variant_id), _), - T.Adt (T.AdtId def_id', regions, types) ) -> - assert (def_id = def_id'); - compute_expanded_bottom_adt_value ctx.type_context.type_defs def_id - opt_variant_id regions types - (* Tuples *) - | Field (ProjTuple arity, _), T.Adt (T.Tuple, [], tys) -> - assert (arity = List.length tys); - (* Generate the field values *) - compute_expanded_bottom_tuple_value tys - | _ -> - failwith - ("Unreachable: " ^ E.show_projection_elem pe ^ ", " ^ T.show_ety ty) - in - (* Update the context by inserting the expanded value at the proper place *) - match write_place config access p' nv ctx with - | Ok ctx -> ctx - | Error _ -> failwith "Unreachable" - -(** Update the environment to be able to read a place. - - When reading a place, we may be stuck along the way because some value - is borrowed, we reach a symbolic value, etc. In this situation [read_place] - fails while returning precise information about the failure. This function - uses this information to update the environment (by ending borrows, - expanding symbolic values) until we manage to fully read the place. - *) -let rec update_ctx_along_read_place (config : C.config) (access : access_kind) - (p : E.place) (ctx : C.eval_ctx) : C.eval_ctx = - (* Attempt to read the place: if it fails, update the environment and retry *) - match read_place config access p ctx with - | Ok _ -> ctx - | Error err -> - let ctx = - match err with - | FailSharedLoan bids -> end_outer_borrows config bids ctx - | FailMutLoan bid -> end_outer_borrow config bid ctx - | FailInactivatedMutBorrow bid -> - activate_inactivated_mut_borrow config Outer bid ctx - | FailSymbolic (pe, sp) -> - (* Expand the symbolic value *) - expand_symbolic_value_no_branching config pe sp ctx - | FailBottom (_, _, _) -> - (* We can't expand [Bottom] values while reading them *) - failwith "Found [Bottom] while reading a place" - | FailBorrow _ -> failwith "Could not read a borrow" - in - update_ctx_along_read_place config access p ctx - -(** Update the environment to be able to write to a place. - - See [update_env_alond_read_place]. -*) -let rec update_ctx_along_write_place (config : C.config) (access : access_kind) - (p : E.place) (ctx : C.eval_ctx) : C.eval_ctx = - (* Attempt to *read* (yes, "read": we check the access to the place, and - write to it later) the place: if it fails, update the environment and retry *) - match read_place config access p ctx with - | Ok _ -> ctx - | Error err -> - let ctx = - match err with - | FailSharedLoan bids -> end_outer_borrows config bids ctx - | FailMutLoan bid -> end_outer_borrow config bid ctx - | FailInactivatedMutBorrow bid -> - activate_inactivated_mut_borrow config Outer bid ctx - | FailSymbolic (pe, sp) -> - (* Expand the symbolic value *) - expand_symbolic_value_no_branching config pe sp ctx - | FailBottom (remaining_pes, pe, ty) -> - (* Expand the [Bottom] value *) - expand_bottom_value_from_projection config access p remaining_pes pe - ty ctx - | FailBorrow _ -> failwith "Could not write to a borrow" - in - update_ctx_along_write_place config access p ctx - -exception UpdateCtx of C.eval_ctx -(** Small utility used to break control-flow *) - -(** End the loans at a given place: read the value, if it contains a loan, - end this loan, repeat. - - This is used when reading, borrowing, writing to a value. We typically - first call [update_ctx_along_read_place] or [update_ctx_along_write_place] - to get access to the value, then call this function to "prepare" the value: - when moving values, we can't move a value which contains loans and thus need - to end them, etc. - *) -let rec end_loans_at_place (config : C.config) (access : access_kind) - (p : E.place) (ctx : C.eval_ctx) : C.eval_ctx = - (* Iterator to explore a value and update the context whenever we find - * loans. - * We use exceptions to make it handy: whenever we update the - * context, we raise an exception wrapping the updated context. - * *) - let obj = - object - inherit [_] V.iter_typed_value as super - - method! visit_borrow_content env bc = - match bc with - | V.SharedBorrow _ | V.MutBorrow (_, _) -> - (* Nothing special to do *) super#visit_borrow_content env bc - | V.InactivatedMutBorrow bid -> - (* We need to activate inactivated borrows *) - let ctx = activate_inactivated_mut_borrow config Inner bid ctx in - raise (UpdateCtx ctx) - - method! visit_loan_content env lc = - match lc with - | V.SharedLoan (bids, v) -> ( - (* End the loans if we need a modification access, otherwise dive into - the shared value *) - match access with - | Read -> super#visit_SharedLoan env bids v - | Write | Move -> - let ctx = end_outer_borrows config bids ctx in - raise (UpdateCtx ctx)) - | V.MutLoan bid -> - (* We always need to end mutable borrows *) - let ctx = end_outer_borrow config bid ctx in - raise (UpdateCtx ctx) - end - in - - (* First, retrieve the value *) - match read_place config access p ctx with - | Error _ -> failwith "Unreachable" - | Ok v -> ( - (* Inspect the value and update the context while doing so. - If the context gets updated: perform a recursive call (many things - may have been updated in the context: we need to re-read the value - at place [p] - and this value may actually not be accessible - anymore...) - *) - try - obj#visit_typed_value () v; - (* No context update required: return the current context *) - ctx - with UpdateCtx ctx -> - (* The context was updated: do a recursive call to reinspect the value *) - end_loans_at_place config access p ctx) - -(** Drop (end) all the loans and borrows at a given place, which should be - seen as an l-value (we will write to it later, but need to drop the borrows - before writing). - - We start by only dropping the borrows, then we end the loans. The reason - is that some loan we find may be borrowed by another part of the subvalue. - In order to correctly handle the "outer borrow" priority (we should end - the outer borrows first) which is not really applied here (we are preparing - the value for override: we can end the borrows inside, without ending the - borrows we traversed to actually access the value) we first end the borrows - we find in the place, to make sure all the "local" loans are taken care of. - Then, if we find a loan, it means it is "externally" borrowed (the associated - borrow is not in a subvalue of the place under inspection). - Also note that whenever we end a loan, we might propagate back a value inside - the place under inspection: we must re-end all the borrows we find there, - before reconsidering loans. - - Repeat: - - read the value at a given place - - as long as we find a loan or a borrow, end it - - This is used to drop values (when we need to write to a place, we first - drop the value there to properly propagate back values which are not/can't - be borrowed anymore). - *) -let rec drop_borrows_loans_at_lplace (config : C.config) (p : E.place) - (ctx : C.eval_ctx) : C.eval_ctx = - (* Iterator to explore a value and update the context whenever we find - borrows/loans. - We use exceptions to make it handy: whenever we update the - context, we raise an exception wrapping the updated context. - - Note that we can end the borrows which are inside the value (while the - value itself might be inside a borrow/loan: we are thus ending inner - borrows). Because a loan inside the value may be linked to a borrow - somewhere else *also inside* the value (it's possible with adts), - we first end all the borrows we find - by using [Inner] to allow - ending inner borrows - then end all the loans we find. - - It is really important to do this in two steps: the borrow linked to a - loan may be inside the value at place p, in which case this borrow may be - an inner borrow that we *can* end, but it may also be outside this - value, in which case we need to end all the outer borrows first... - Also, whenever the context is updated, we need to re-inspect - the value at place p *in two steps* again (end borrows, then end - loans). - - Example: - ======= - We want to end the borrows/loans at `*x` in the following environment: - ``` - x -> mut_borrow l0 (mut_loan l1, mut_borrow l1 (Int 3), mut_loan l2) - y -> mut_borrow l2 (Bool true) - ``` - - We have to consider two things: - - the borrow `mut_borrow l1 (Int 3)` borrows a subvalue of `*x` - - the borrow corresponding to the loan `mut_loan l2` is outside of `*x` - - We first end all the *borrows* (not the loans) inside of `*x`, which gives: - ``` - x -> mut_borrow l0 (Int 3, ⊥, mut_loan l2) - y -> mut_borrow l2 (Bool true) - ``` - - Note that when ending the borrows, we can (and have to) ignore the outer - borrows (in this case `mut_borrow l0 ...`). Otherwise, we would have to end - the borrow `l0` which is incorrect (note that we might have to drop the - borrows/loans at `*x` if we evaluate, for instance, `*x = ...`). - It is ok to ignore outer borrows in this case because whenever - we end a borrow, it is an outer borrow locally to `*x` (i.e., we ignore - the outer borrows when accessing `*x`, but once examining the value at - `*x` we never dive into borrows: whenever we find one, we end it - it is thus - an outer borrow, in some way). - - Then, we end the loans at `*x`. Note that as at this point `*x` doesn't - contain borrows (only loans), the borrows corresponding to those loans - are thus necessarily outside of `*x`: we mustn't ignore outer borrows this - time. This gives: - ``` - x -> mut_borrow l0 (Int 3, ⊥, Bool true) - y -> ⊥ - ``` - *) - let obj = - object - inherit [_] V.iter_typed_value as super - - method! visit_borrow_content end_loans bc = - (* Sanity check: we should have ended all the borrows before starting - to end loans *) - assert (not end_loans); - - (* We need to end all borrows. Note that we ignore the outer borrows - when ending the borrows we find here (we call [end_inner_borrow(s)]: - the value at place p might be below a borrow/loan). Note however - that if we restrain ourselves at the value at place p, the borrow we - found here can be considered as an outer borrow. - *) - match bc with - | V.SharedBorrow bid | V.MutBorrow (bid, _) -> - raise (UpdateCtx (end_inner_borrow config bid ctx)) - | V.InactivatedMutBorrow bid -> - (* We need to activate ithe nactivated borrow - later, we will - * actually end it - Rk.: we could actually end it straight away - * (this is not really important) *) - let ctx = activate_inactivated_mut_borrow config Inner bid ctx in - raise (UpdateCtx ctx) - - method! visit_loan_content end_loans lc = - if - (* If we can, end the loans, otherwise ignore: keep for later *) - end_loans - then - (* We need to end all loans. Note that as all the borrows inside - the value at place p should already have ended, the borrows - associated to the loans we find here should be borrows from - outside this value: we need to call [end_outer_borrow(s)] - (we can't ignore outer borrows this time). - *) - match lc with - | V.SharedLoan (bids, _) -> - raise (UpdateCtx (end_outer_borrows config bids ctx)) - | V.MutLoan bid -> raise (UpdateCtx (end_outer_borrow config bid ctx)) - else super#visit_loan_content end_loans lc - end - in - - (* We do something similar to [end_loans_at_place]. - First, retrieve the value *) - match read_place config Write p ctx with - | Error _ -> failwith "Unreachable" - | Ok v -> ( - (* Inspect the value and update the context while doing so. - If the context gets updated: perform a recursive call (many things - may have been updated in the context: first we need to retrieve the - proper updated value - and this value may actually not be accessible - anymore - *) - try - (* Inspect the value: end the borrows only *) - obj#visit_typed_value false v; - (* Inspect the value: end the loans *) - obj#visit_typed_value true v; - (* No context update required: return the current context *) - ctx - with UpdateCtx ctx -> drop_borrows_loans_at_lplace config p ctx) - -(** Copy a value, and return the resulting value. - - Note that copying values might update the context. For instance, when - copying shared borrows, we need to insert new shared borrows in the context. - - Also, this function is actually more general than it should be: it can be used - to copy concrete ADT values, while ADT copy should be done through the Copy - trait (i.e., by calling a dedicated function). This is why we added a parameter - to control this copy. Note that here by ADT we mean the user-defined ADTs - (not tuples or assumed types). - *) -let rec copy_value (allow_adt_copy : bool) (config : C.config) - (ctx : C.eval_ctx) (v : V.typed_value) : C.eval_ctx * V.typed_value = - (* Remark: at some point we rewrote this function to use iterators, but then - * we reverted the changes: the result was less clear actually. In particular, - * the fact that we have exhaustive matches below makes very obvious the cases - * in which we need to fail *) - match v.V.value with - | V.Concrete _ -> (ctx, v) - | V.Adt av -> - (* Sanity check *) - (match v.V.ty with - | T.Adt (T.Assumed _, _, _) -> failwith "Can't copy an assumed value" - | T.Adt (T.AdtId _, _, _) -> assert allow_adt_copy - | T.Adt (T.Tuple, _, _) -> () (* Ok *) - | _ -> failwith "Unreachable"); - let ctx, fields = - List.fold_left_map - (copy_value allow_adt_copy config) - ctx av.field_values - in - (ctx, { v with V.value = V.Adt { av with field_values = fields } }) - | V.Bottom -> failwith "Can't copy ⊥" - | V.Borrow bc -> ( - (* We can only copy shared borrows *) - match bc with - | SharedBorrow bid -> - (* We need to create a new borrow id for the copied borrow, and - * update the context accordingly *) - let ctx, bid' = C.fresh_borrow_id ctx in - let ctx = reborrow_shared bid bid' ctx in - (ctx, { v with V.value = V.Borrow (SharedBorrow bid') }) - | MutBorrow (_, _) -> failwith "Can't copy a mutable borrow" - | V.InactivatedMutBorrow _ -> - failwith "Can't copy an inactivated mut borrow") - | V.Loan lc -> ( - (* We can only copy shared loans *) - match lc with - | V.MutLoan _ -> failwith "Can't copy a mutable loan" - | V.SharedLoan (_, sv) -> - (* We don't copy the shared loan: only the shared value inside *) - copy_value allow_adt_copy config ctx sv) - | V.Symbolic sp -> - (* We can copy only if the type is "primitively" copyable. - * Note that in the general case, copy is a trait: copying values - * thus requires calling the proper function. Here, we copy values - * for very simple types such as integers, shared borrows, etc. *) - assert ( - type_is_primitively_copyable (Subst.erase_regions sp.V.svalue.V.sv_ty)); - (* If the type is copyable, we simply return the current value. Side - * remark: what is important to look at when copying symbolic values - * is symbolic expansion. The important subcase is the expansion of shared - * borrows: when doing so, every occurrence of the same symbolic value - * must use a fresh borrow id. *) - (ctx, v) - (** Convert a constant operand value to a typed value *) let constant_value_to_typed_value (ctx : C.eval_ctx) (ty : T.ety) (cv : E.operand_constant_value) : V.typed_value = @@ -1243,50 +473,6 @@ let eval_rvalue (config : C.config) (ctx : C.eval_ctx) (rvalue : E.rvalue) : (** Result of evaluating a statement *) type statement_eval_res = Unit | Break of int | Continue of int | Return -(** Small utility. - - Prepare a place which is to be used as the destination of an assignment: - update the environment along the paths, end the borrows and loans at - this place, etc. - - Return the updated context and the (updated) value at the end of the - place. This value should not contain any loan or borrow (and we check - it is the case). Note that it is very likely to contain [Bottom] values. - *) -let prepare_lplace (config : C.config) (p : E.place) (ctx : C.eval_ctx) : - C.eval_ctx * V.typed_value = - (* TODO *) - let access = Write in - let ctx = update_ctx_along_write_place config access p ctx in - (* End the borrows and loans, starting with the borrows *) - let ctx = drop_borrows_loans_at_lplace config p ctx in - (* Read the value and check it *) - let v = read_place_unwrap config access p ctx in - (* Sanity checks *) - assert (not (loans_in_value v)); - assert (not (borrows_in_value v)); - (* Return *) - (ctx, v) - -(** Read the value at a given place. - As long as it is a loan, end the loan. - This function doesn't perform a recursive exploration: - it won't dive into the value to end all the inner - loans (contrary to [drop_borrows_loans_at_lplace] for - instance). - *) -let rec end_loan_exactly_at_place (config : C.config) (access : access_kind) - (p : E.place) (ctx : C.eval_ctx) : C.eval_ctx = - let v = read_place_unwrap config access p ctx in - match v.V.value with - | V.Loan (V.SharedLoan (bids, _)) -> - let ctx = end_outer_borrows config bids ctx in - end_loan_exactly_at_place config access p ctx - | V.Loan (V.MutLoan bid) -> - let ctx = end_outer_borrow config bid ctx in - end_loan_exactly_at_place config access p ctx - | _ -> ctx - (** Updates the discriminant of a value at a given place. There are two situations: diff --git a/src/InterpreterPaths.ml b/src/InterpreterPaths.ml new file mode 100644 index 00000000..7e9fa7dd --- /dev/null +++ b/src/InterpreterPaths.ml @@ -0,0 +1,833 @@ +module T = Types +module V = Values +open Scalars +module E = Expressions +open Errors +module C = Contexts +module Subst = Substitute +module A = CfimAst +module L = Logging +open TypesUtils +open ValuesUtils +module Inv = Invariants +module S = Synthesis +open Utils +open InterpreterUtils +open InterpreterProjectors +open InterpreterBorrows +open InterpreterExpansion + +(** Paths *) + +(** When we fail reading from or writing to a path, it might be because we + need to update the environment by ending borrows, expanding symbolic + values, etc. The following type is used to convey this information. + + TODO: compare with borrow_lres? +*) +type path_fail_kind = + | FailSharedLoan of V.BorrowId.Set.t + (** Failure because we couldn't go inside a shared loan *) + | FailMutLoan of V.BorrowId.id + (** Failure because we couldn't go inside a mutable loan *) + | FailInactivatedMutBorrow of V.BorrowId.id + (** Failure because we couldn't go inside an inactivated mutable borrow + (which should get activated) *) + | FailSymbolic of (E.projection_elem * V.symbolic_proj_comp) + (** Failure because we need to enter a symbolic value (and thus need to expand it) *) + (* TODO: Remove the parentheses *) + | FailBottom of (int * E.projection_elem * T.ety) + (** Failure because we need to enter an any value - we can expand Bottom + values if they are left values. We return the number of elements which + were remaining in the path when we reached the error - this allows to + properly update the Bottom value, if needs be. + *) + | FailBorrow of V.borrow_content + (** We got stuck because we couldn't enter a borrow *) + +(** Result of evaluating a path (reading from a path/writing to a path) + + Note that when we fail, we return information used to update the + environment, as well as the +*) +type 'a path_access_result = ('a, path_fail_kind) result +(** The result of reading from/writing to a place *) + +type updated_read_value = { read : V.typed_value; updated : V.typed_value } + +type projection_access = { + enter_shared_loans : bool; + enter_mut_borrows : bool; + lookup_shared_borrows : bool; +} + +(** Generic function to access (read/write) the value at the end of a projection. + + We return the (eventually) updated value, the value we read at the end of + the place and the (eventually) updated environment. + + TODO: use exceptions? + *) +let rec access_projection (access : projection_access) (ctx : C.eval_ctx) + (* Function to (eventually) update the value we find *) + (update : V.typed_value -> V.typed_value) (p : E.projection) + (v : V.typed_value) : (C.eval_ctx * updated_read_value) path_access_result = + (* For looking up/updating shared loans *) + let ek : exploration_kind = + { enter_shared_loans = true; enter_mut_borrows = true; enter_abs = true } + in + match p with + | [] -> + let nv = update v in + (* Type checking *) + if nv.ty <> v.ty then ( + L.log#lerror + (lazy + ("Not the same type:\n- nv.ty: " ^ T.show_ety nv.ty ^ "\n- v.ty: " + ^ T.show_ety v.ty)); + failwith + "Assertion failed: new value doesn't have the same type as its \ + destination"); + Ok (ctx, { read = v; updated = nv }) + | pe :: p' -> ( + (* Match on the projection element and the value *) + match (pe, v.V.value, v.V.ty) with + (* Field projection - ADTs *) + | ( Field (ProjAdt (def_id, opt_variant_id), field_id), + V.Adt adt, + T.Adt (T.AdtId def_id', _, _) ) -> ( + assert (def_id = def_id'); + (* Check that the projection is consistent with the current value *) + (match (opt_variant_id, adt.variant_id) with + | None, None -> () + | Some vid, Some vid' -> if vid <> vid' then failwith "Unreachable" + | _ -> failwith "Unreachable"); + (* Actually project *) + let fv = T.FieldId.nth adt.field_values field_id in + match access_projection access ctx update p' fv with + | Error err -> Error err + | Ok (ctx, res) -> + (* Update the field value *) + let nvalues = + T.FieldId.update_nth adt.field_values field_id res.updated + in + let nadt = V.Adt { adt with V.field_values = nvalues } in + let updated = { v with value = nadt } in + Ok (ctx, { res with updated })) + (* Tuples *) + | Field (ProjTuple arity, field_id), V.Adt adt, T.Adt (T.Tuple, _, _) -> ( + assert (arity = List.length adt.field_values); + let fv = T.FieldId.nth adt.field_values field_id in + (* Project *) + match access_projection access ctx update p' fv with + | Error err -> Error err + | Ok (ctx, res) -> + (* Update the field value *) + let nvalues = + T.FieldId.update_nth adt.field_values field_id res.updated + in + let ntuple = V.Adt { adt with field_values = nvalues } in + let updated = { v with value = ntuple } in + Ok (ctx, { res with updated }) + (* If we reach Bottom, it may mean we need to expand an uninitialized + * enumeration value *)) + | Field (ProjAdt (_, _), _), V.Bottom, _ -> + Error (FailBottom (1 + List.length p', pe, v.ty)) + | Field (ProjTuple _, _), V.Bottom, _ -> + Error (FailBottom (1 + List.length p', pe, v.ty)) + (* Symbolic value: needs to be expanded *) + | _, Symbolic sp, _ -> + (* Expand the symbolic value *) + Error (FailSymbolic (pe, sp)) + (* Box dereferencement *) + | ( DerefBox, + Adt { variant_id = None; field_values = [ bv ] }, + T.Adt (T.Assumed T.Box, _, _) ) -> ( + (* We allow moving inside of boxes. In practice, this kind of + * manipulations should happen only inside unsage code, so + * it shouldn't happen due to user code, and we leverage it + * when implementing box dereferencement for the concrete + * interpreter *) + match access_projection access ctx update p' bv with + | Error err -> Error err + | Ok (ctx, res) -> + let nv = + { + v with + value = + V.Adt { variant_id = None; field_values = [ res.updated ] }; + } + in + Ok (ctx, { res with updated = nv })) + (* Borrows *) + | Deref, V.Borrow bc, _ -> ( + match bc with + | V.SharedBorrow bid -> + (* Lookup the loan content, and explore from there *) + if access.lookup_shared_borrows then + match lookup_loan ek bid ctx with + | _, Concrete (V.MutLoan _) -> failwith "Expected a shared loan" + | _, Concrete (V.SharedLoan (bids, sv)) -> ( + (* Explore the shared value *) + match access_projection access ctx update p' sv with + | Error err -> Error err + | Ok (ctx, res) -> + (* Update the shared loan with the new value returned + by [access_projection] *) + let ctx = + update_loan ek bid + (V.SharedLoan (bids, res.updated)) + ctx + in + (* Return - note that we don't need to update the borrow itself *) + Ok (ctx, { res with updated = v })) + | ( _, + Abstract + ( V.AMutLoan (_, _) + | V.AEndedMutLoan { given_back = _; child = _ } + | V.AEndedSharedLoan (_, _) + | V.AIgnoredMutLoan (_, _) + | V.AEndedIgnoredMutLoan { given_back = _; child = _ } + | V.AIgnoredSharedLoan _ ) ) -> + failwith "Expected a shared (abstraction) loan" + | _, Abstract (V.ASharedLoan (bids, sv, _av)) -> ( + (* Explore the shared value *) + match access_projection access ctx update p' sv with + | Error err -> Error err + | Ok (ctx, res) -> + (* Relookup the child avalue *) + let av = + match lookup_loan ek bid ctx with + | _, Abstract (V.ASharedLoan (_, _, av)) -> av + | _ -> failwith "Unexpected" + in + (* Update the shared loan with the new value returned + by [access_projection] *) + let ctx = + update_aloan ek bid + (V.ASharedLoan (bids, res.updated, av)) + ctx + in + (* Return - note that we don't need to update the borrow itself *) + Ok (ctx, { res with updated = v })) + else Error (FailBorrow bc) + | V.InactivatedMutBorrow bid -> Error (FailInactivatedMutBorrow bid) + | V.MutBorrow (bid, bv) -> + if access.enter_mut_borrows then + match access_projection access ctx update p' bv with + | Error err -> Error err + | Ok (ctx, res) -> + let nv = + { + v with + value = V.Borrow (V.MutBorrow (bid, res.updated)); + } + in + Ok (ctx, { res with updated = nv }) + else Error (FailBorrow bc)) + | _, V.Loan lc, _ -> ( + match lc with + | V.MutLoan bid -> Error (FailMutLoan bid) + | V.SharedLoan (bids, sv) -> + (* If we can enter shared loan, we ignore the loan. Pay attention + to the fact that we need to reexplore the *whole* place (i.e, + we mustn't ignore the current projection element *) + if access.enter_shared_loans then + match access_projection access ctx update (pe :: p') sv with + | Error err -> Error err + | Ok (ctx, res) -> + let nv = + { + v with + value = V.Loan (V.SharedLoan (bids, res.updated)); + } + in + Ok (ctx, { res with updated = nv }) + else Error (FailSharedLoan bids)) + | (_, (V.Concrete _ | V.Adt _ | V.Bottom | V.Borrow _), _) as r -> + let pe, v, ty = r in + let pe = "- pe: " ^ E.show_projection_elem pe in + let v = "- v:\n" ^ V.show_value v in + let ty = "- ty:\n" ^ T.show_ety ty in + L.log#serror ("Inconsistent projection:\n" ^ pe ^ "\n" ^ v ^ "\n" ^ ty); + failwith "Inconsistent projection") + +(** Generic function to access (read/write) the value at a given place. + + We return the value we read at the place and the (eventually) updated + environment, if we managed to access the place, or the precise reason + why we failed. + *) +let access_place (access : projection_access) + (* Function to (eventually) update the value we find *) + (update : V.typed_value -> V.typed_value) (p : E.place) (ctx : C.eval_ctx) + : (C.eval_ctx * V.typed_value) path_access_result = + (* Lookup the variable's value *) + let value = C.ctx_lookup_var_value ctx p.var_id in + (* Apply the projection *) + match access_projection access ctx update p.projection value with + | Error err -> Error err + | Ok (ctx, res) -> + (* Update the value *) + let ctx = C.ctx_update_var_value ctx p.var_id res.updated in + (* Return *) + Ok (ctx, res.read) + +type access_kind = + | Read (** We can go inside borrows and loans *) + | Write (** Don't enter shared borrows or shared loans *) + | Move (** Don't enter borrows or loans *) + +let access_kind_to_projection_access (access : access_kind) : projection_access + = + match access with + | Read -> + { + enter_shared_loans = true; + enter_mut_borrows = true; + lookup_shared_borrows = true; + } + | Write -> + { + enter_shared_loans = false; + enter_mut_borrows = true; + lookup_shared_borrows = false; + } + | Move -> + { + enter_shared_loans = false; + enter_mut_borrows = false; + lookup_shared_borrows = false; + } + +(** Read the value at a given place *) +let read_place (config : C.config) (access : access_kind) (p : E.place) + (ctx : C.eval_ctx) : V.typed_value path_access_result = + let access = access_kind_to_projection_access access in + (* The update function is the identity *) + let update v = v in + match access_place access update p ctx with + | Error err -> Error err + | Ok (ctx1, read_value) -> + (* Note that we ignore the new environment: it should be the same as the + original one. + *) + if config.check_invariants then + if ctx1 <> ctx then ( + let msg = + "Unexpected environment update:\nNew environment:\n" + ^ C.show_env ctx1.env ^ "\n\nOld environment:\n" + ^ C.show_env ctx.env + in + L.log#serror msg; + failwith "Unexpected environment update"); + Ok read_value + +let read_place_unwrap (config : C.config) (access : access_kind) (p : E.place) + (ctx : C.eval_ctx) : V.typed_value = + match read_place config access p ctx with + | Error _ -> failwith "Unreachable" + | Ok v -> v + +(** Update the value at a given place *) +let write_place (_config : C.config) (access : access_kind) (p : E.place) + (nv : V.typed_value) (ctx : C.eval_ctx) : C.eval_ctx path_access_result = + let access = access_kind_to_projection_access access in + (* The update function substitutes the value with the new value *) + let update _ = nv in + match access_place access update p ctx with + | Error err -> Error err + | Ok (ctx, _) -> + (* We ignore the read value *) + Ok ctx + +let write_place_unwrap (config : C.config) (access : access_kind) (p : E.place) + (nv : V.typed_value) (ctx : C.eval_ctx) : C.eval_ctx = + match write_place config access p nv ctx with + | Error _ -> failwith "Unreachable" + | Ok ctx -> ctx + +(** Compute an expanded ADT bottom value *) +let compute_expanded_bottom_adt_value (tyctx : T.type_def list) + (def_id : T.TypeDefId.id) (opt_variant_id : T.VariantId.id option) + (regions : T.erased_region list) (types : T.ety list) : V.typed_value = + (* Lookup the definition and check if it is an enumeration - it + should be an enumeration if and only if the projection element + is a field projection with *some* variant id. Retrieve the list + of fields at the same time. *) + let def = T.TypeDefId.nth tyctx def_id in + assert (List.length regions = List.length def.T.region_params); + (* Compute the field types *) + let field_types = + Subst.type_def_get_instantiated_field_etypes def opt_variant_id types + in + (* Initialize the expanded value *) + let fields = + List.map + (fun ty : V.typed_value -> ({ V.value = V.Bottom; ty } : V.typed_value)) + field_types + in + let av = V.Adt { variant_id = opt_variant_id; field_values = fields } in + let ty = T.Adt (T.AdtId def_id, regions, types) in + { V.value = av; V.ty } + +(** Compute an expanded tuple bottom value *) +let compute_expanded_bottom_tuple_value (field_types : T.ety list) : + V.typed_value = + (* Generate the field values *) + let fields = + List.map (fun ty : V.typed_value -> { V.value = Bottom; ty }) field_types + in + let v = V.Adt { variant_id = None; field_values = fields } in + let ty = T.Adt (T.Tuple, [], field_types) in + { V.value = v; V.ty } + +(** Auxiliary helper to expand [Bottom] values. + + During compilation, rustc desaggregates the ADT initializations. The + consequence is that the following rust code: + ``` + let x = Cons a b; + ``` + + Looks like this in MIR: + ``` + (x as Cons).0 = a; + (x as Cons).1 = b; + set_discriminant(x, 0); // If `Cons` is the variant of index 0 + ``` + + The consequence is that we may sometimes need to write fields to values + which are currently [Bottom]. When doing this, we first expand the value + to, say, [Cons Bottom Bottom] (note that field projection contains information + about which variant we should project to, which is why we *can* set the + variant index when writing one of its fields). +*) +let expand_bottom_value_from_projection (config : C.config) + (access : access_kind) (p : E.place) (remaining_pes : int) + (pe : E.projection_elem) (ty : T.ety) (ctx : C.eval_ctx) : C.eval_ctx = + (* Debugging *) + L.log#ldebug + (lazy + ("expand_bottom_value_from_projection:\n" ^ "pe: " + ^ E.show_projection_elem pe ^ "\n" ^ "ty: " ^ T.show_ety ty)); + (* Prepare the update: we need to take the proper prefix of the place + during whose evaluation we got stuck *) + let projection' = + fst + (Utilities.list_split_at p.projection + (List.length p.projection - remaining_pes)) + in + let p' = { p with projection = projection' } in + (* Compute the expanded value. + The type of the [Bottom] value should be a tuple or an ADT. + Note that the projection element we got stuck at should be a + field projection, and gives the variant id if the [Bottom] value + is an enumeration value. + Also, the expanded value should be the proper ADT variant or a tuple + with the proper arity, with all the fields initialized to [Bottom] + *) + let nv = + match (pe, ty) with + (* "Regular" ADTs *) + | ( Field (ProjAdt (def_id, opt_variant_id), _), + T.Adt (T.AdtId def_id', regions, types) ) -> + assert (def_id = def_id'); + compute_expanded_bottom_adt_value ctx.type_context.type_defs def_id + opt_variant_id regions types + (* Tuples *) + | Field (ProjTuple arity, _), T.Adt (T.Tuple, [], tys) -> + assert (arity = List.length tys); + (* Generate the field values *) + compute_expanded_bottom_tuple_value tys + | _ -> + failwith + ("Unreachable: " ^ E.show_projection_elem pe ^ ", " ^ T.show_ety ty) + in + (* Update the context by inserting the expanded value at the proper place *) + match write_place config access p' nv ctx with + | Ok ctx -> ctx + | Error _ -> failwith "Unreachable" + +(** Update the environment to be able to read a place. + + When reading a place, we may be stuck along the way because some value + is borrowed, we reach a symbolic value, etc. In this situation [read_place] + fails while returning precise information about the failure. This function + uses this information to update the environment (by ending borrows, + expanding symbolic values) until we manage to fully read the place. + *) +let rec update_ctx_along_read_place (config : C.config) (access : access_kind) + (p : E.place) (ctx : C.eval_ctx) : C.eval_ctx = + (* Attempt to read the place: if it fails, update the environment and retry *) + match read_place config access p ctx with + | Ok _ -> ctx + | Error err -> + let ctx = + match err with + | FailSharedLoan bids -> end_outer_borrows config bids ctx + | FailMutLoan bid -> end_outer_borrow config bid ctx + | FailInactivatedMutBorrow bid -> + activate_inactivated_mut_borrow config Outer bid ctx + | FailSymbolic (pe, sp) -> + (* Expand the symbolic value *) + expand_symbolic_value_no_branching config pe sp ctx + | FailBottom (_, _, _) -> + (* We can't expand [Bottom] values while reading them *) + failwith "Found [Bottom] while reading a place" + | FailBorrow _ -> failwith "Could not read a borrow" + in + update_ctx_along_read_place config access p ctx + +(** Update the environment to be able to write to a place. + + See [update_env_alond_read_place]. +*) +let rec update_ctx_along_write_place (config : C.config) (access : access_kind) + (p : E.place) (ctx : C.eval_ctx) : C.eval_ctx = + (* Attempt to *read* (yes, "read": we check the access to the place, and + write to it later) the place: if it fails, update the environment and retry *) + match read_place config access p ctx with + | Ok _ -> ctx + | Error err -> + let ctx = + match err with + | FailSharedLoan bids -> end_outer_borrows config bids ctx + | FailMutLoan bid -> end_outer_borrow config bid ctx + | FailInactivatedMutBorrow bid -> + activate_inactivated_mut_borrow config Outer bid ctx + | FailSymbolic (pe, sp) -> + (* Expand the symbolic value *) + expand_symbolic_value_no_branching config pe sp ctx + | FailBottom (remaining_pes, pe, ty) -> + (* Expand the [Bottom] value *) + expand_bottom_value_from_projection config access p remaining_pes pe + ty ctx + | FailBorrow _ -> failwith "Could not write to a borrow" + in + update_ctx_along_write_place config access p ctx + +exception UpdateCtx of C.eval_ctx +(** Small utility used to break control-flow *) + +(** End the loans at a given place: read the value, if it contains a loan, + end this loan, repeat. + + This is used when reading, borrowing, writing to a value. We typically + first call [update_ctx_along_read_place] or [update_ctx_along_write_place] + to get access to the value, then call this function to "prepare" the value: + when moving values, we can't move a value which contains loans and thus need + to end them, etc. + *) +let rec end_loans_at_place (config : C.config) (access : access_kind) + (p : E.place) (ctx : C.eval_ctx) : C.eval_ctx = + (* Iterator to explore a value and update the context whenever we find + * loans. + * We use exceptions to make it handy: whenever we update the + * context, we raise an exception wrapping the updated context. + * *) + let obj = + object + inherit [_] V.iter_typed_value as super + + method! visit_borrow_content env bc = + match bc with + | V.SharedBorrow _ | V.MutBorrow (_, _) -> + (* Nothing special to do *) super#visit_borrow_content env bc + | V.InactivatedMutBorrow bid -> + (* We need to activate inactivated borrows *) + let ctx = activate_inactivated_mut_borrow config Inner bid ctx in + raise (UpdateCtx ctx) + + method! visit_loan_content env lc = + match lc with + | V.SharedLoan (bids, v) -> ( + (* End the loans if we need a modification access, otherwise dive into + the shared value *) + match access with + | Read -> super#visit_SharedLoan env bids v + | Write | Move -> + let ctx = end_outer_borrows config bids ctx in + raise (UpdateCtx ctx)) + | V.MutLoan bid -> + (* We always need to end mutable borrows *) + let ctx = end_outer_borrow config bid ctx in + raise (UpdateCtx ctx) + end + in + + (* First, retrieve the value *) + match read_place config access p ctx with + | Error _ -> failwith "Unreachable" + | Ok v -> ( + (* Inspect the value and update the context while doing so. + If the context gets updated: perform a recursive call (many things + may have been updated in the context: we need to re-read the value + at place [p] - and this value may actually not be accessible + anymore...) + *) + try + obj#visit_typed_value () v; + (* No context update required: return the current context *) + ctx + with UpdateCtx ctx -> + (* The context was updated: do a recursive call to reinspect the value *) + end_loans_at_place config access p ctx) + +(** Drop (end) all the loans and borrows at a given place, which should be + seen as an l-value (we will write to it later, but need to drop the borrows + before writing). + + We start by only dropping the borrows, then we end the loans. The reason + is that some loan we find may be borrowed by another part of the subvalue. + In order to correctly handle the "outer borrow" priority (we should end + the outer borrows first) which is not really applied here (we are preparing + the value for override: we can end the borrows inside, without ending the + borrows we traversed to actually access the value) we first end the borrows + we find in the place, to make sure all the "local" loans are taken care of. + Then, if we find a loan, it means it is "externally" borrowed (the associated + borrow is not in a subvalue of the place under inspection). + Also note that whenever we end a loan, we might propagate back a value inside + the place under inspection: we must re-end all the borrows we find there, + before reconsidering loans. + + Repeat: + - read the value at a given place + - as long as we find a loan or a borrow, end it + + This is used to drop values (when we need to write to a place, we first + drop the value there to properly propagate back values which are not/can't + be borrowed anymore). + *) +let rec drop_borrows_loans_at_lplace (config : C.config) (p : E.place) + (ctx : C.eval_ctx) : C.eval_ctx = + (* Iterator to explore a value and update the context whenever we find + borrows/loans. + We use exceptions to make it handy: whenever we update the + context, we raise an exception wrapping the updated context. + + Note that we can end the borrows which are inside the value (while the + value itself might be inside a borrow/loan: we are thus ending inner + borrows). Because a loan inside the value may be linked to a borrow + somewhere else *also inside* the value (it's possible with adts), + we first end all the borrows we find - by using [Inner] to allow + ending inner borrows - then end all the loans we find. + + It is really important to do this in two steps: the borrow linked to a + loan may be inside the value at place p, in which case this borrow may be + an inner borrow that we *can* end, but it may also be outside this + value, in which case we need to end all the outer borrows first... + Also, whenever the context is updated, we need to re-inspect + the value at place p *in two steps* again (end borrows, then end + loans). + + Example: + ======= + We want to end the borrows/loans at `*x` in the following environment: + ``` + x -> mut_borrow l0 (mut_loan l1, mut_borrow l1 (Int 3), mut_loan l2) + y -> mut_borrow l2 (Bool true) + ``` + + We have to consider two things: + - the borrow `mut_borrow l1 (Int 3)` borrows a subvalue of `*x` + - the borrow corresponding to the loan `mut_loan l2` is outside of `*x` + + We first end all the *borrows* (not the loans) inside of `*x`, which gives: + ``` + x -> mut_borrow l0 (Int 3, ⊥, mut_loan l2) + y -> mut_borrow l2 (Bool true) + ``` + + Note that when ending the borrows, we can (and have to) ignore the outer + borrows (in this case `mut_borrow l0 ...`). Otherwise, we would have to end + the borrow `l0` which is incorrect (note that we might have to drop the + borrows/loans at `*x` if we evaluate, for instance, `*x = ...`). + It is ok to ignore outer borrows in this case because whenever + we end a borrow, it is an outer borrow locally to `*x` (i.e., we ignore + the outer borrows when accessing `*x`, but once examining the value at + `*x` we never dive into borrows: whenever we find one, we end it - it is thus + an outer borrow, in some way). + + Then, we end the loans at `*x`. Note that as at this point `*x` doesn't + contain borrows (only loans), the borrows corresponding to those loans + are thus necessarily outside of `*x`: we mustn't ignore outer borrows this + time. This gives: + ``` + x -> mut_borrow l0 (Int 3, ⊥, Bool true) + y -> ⊥ + ``` + *) + let obj = + object + inherit [_] V.iter_typed_value as super + + method! visit_borrow_content end_loans bc = + (* Sanity check: we should have ended all the borrows before starting + to end loans *) + assert (not end_loans); + + (* We need to end all borrows. Note that we ignore the outer borrows + when ending the borrows we find here (we call [end_inner_borrow(s)]: + the value at place p might be below a borrow/loan). Note however + that if we restrain ourselves at the value at place p, the borrow we + found here can be considered as an outer borrow. + *) + match bc with + | V.SharedBorrow bid | V.MutBorrow (bid, _) -> + raise (UpdateCtx (end_inner_borrow config bid ctx)) + | V.InactivatedMutBorrow bid -> + (* We need to activate ithe nactivated borrow - later, we will + * actually end it - Rk.: we could actually end it straight away + * (this is not really important) *) + let ctx = activate_inactivated_mut_borrow config Inner bid ctx in + raise (UpdateCtx ctx) + + method! visit_loan_content end_loans lc = + if + (* If we can, end the loans, otherwise ignore: keep for later *) + end_loans + then + (* We need to end all loans. Note that as all the borrows inside + the value at place p should already have ended, the borrows + associated to the loans we find here should be borrows from + outside this value: we need to call [end_outer_borrow(s)] + (we can't ignore outer borrows this time). + *) + match lc with + | V.SharedLoan (bids, _) -> + raise (UpdateCtx (end_outer_borrows config bids ctx)) + | V.MutLoan bid -> raise (UpdateCtx (end_outer_borrow config bid ctx)) + else super#visit_loan_content end_loans lc + end + in + + (* We do something similar to [end_loans_at_place]. + First, retrieve the value *) + match read_place config Write p ctx with + | Error _ -> failwith "Unreachable" + | Ok v -> ( + (* Inspect the value and update the context while doing so. + If the context gets updated: perform a recursive call (many things + may have been updated in the context: first we need to retrieve the + proper updated value - and this value may actually not be accessible + anymore + *) + try + (* Inspect the value: end the borrows only *) + obj#visit_typed_value false v; + (* Inspect the value: end the loans *) + obj#visit_typed_value true v; + (* No context update required: return the current context *) + ctx + with UpdateCtx ctx -> drop_borrows_loans_at_lplace config p ctx) + +(** Copy a value, and return the resulting value. + + Note that copying values might update the context. For instance, when + copying shared borrows, we need to insert new shared borrows in the context. + + Also, this function is actually more general than it should be: it can be used + to copy concrete ADT values, while ADT copy should be done through the Copy + trait (i.e., by calling a dedicated function). This is why we added a parameter + to control this copy. Note that here by ADT we mean the user-defined ADTs + (not tuples or assumed types). + *) +let rec copy_value (allow_adt_copy : bool) (config : C.config) + (ctx : C.eval_ctx) (v : V.typed_value) : C.eval_ctx * V.typed_value = + (* Remark: at some point we rewrote this function to use iterators, but then + * we reverted the changes: the result was less clear actually. In particular, + * the fact that we have exhaustive matches below makes very obvious the cases + * in which we need to fail *) + match v.V.value with + | V.Concrete _ -> (ctx, v) + | V.Adt av -> + (* Sanity check *) + (match v.V.ty with + | T.Adt (T.Assumed _, _, _) -> failwith "Can't copy an assumed value" + | T.Adt (T.AdtId _, _, _) -> assert allow_adt_copy + | T.Adt (T.Tuple, _, _) -> () (* Ok *) + | _ -> failwith "Unreachable"); + let ctx, fields = + List.fold_left_map + (copy_value allow_adt_copy config) + ctx av.field_values + in + (ctx, { v with V.value = V.Adt { av with field_values = fields } }) + | V.Bottom -> failwith "Can't copy ⊥" + | V.Borrow bc -> ( + (* We can only copy shared borrows *) + match bc with + | SharedBorrow bid -> + (* We need to create a new borrow id for the copied borrow, and + * update the context accordingly *) + let ctx, bid' = C.fresh_borrow_id ctx in + let ctx = reborrow_shared bid bid' ctx in + (ctx, { v with V.value = V.Borrow (SharedBorrow bid') }) + | MutBorrow (_, _) -> failwith "Can't copy a mutable borrow" + | V.InactivatedMutBorrow _ -> + failwith "Can't copy an inactivated mut borrow") + | V.Loan lc -> ( + (* We can only copy shared loans *) + match lc with + | V.MutLoan _ -> failwith "Can't copy a mutable loan" + | V.SharedLoan (_, sv) -> + (* We don't copy the shared loan: only the shared value inside *) + copy_value allow_adt_copy config ctx sv) + | V.Symbolic sp -> + (* We can copy only if the type is "primitively" copyable. + * Note that in the general case, copy is a trait: copying values + * thus requires calling the proper function. Here, we copy values + * for very simple types such as integers, shared borrows, etc. *) + assert ( + type_is_primitively_copyable (Subst.erase_regions sp.V.svalue.V.sv_ty)); + (* If the type is copyable, we simply return the current value. Side + * remark: what is important to look at when copying symbolic values + * is symbolic expansion. The important subcase is the expansion of shared + * borrows: when doing so, every occurrence of the same symbolic value + * must use a fresh borrow id. *) + (ctx, v) + +(** Small utility. + + Prepare a place which is to be used as the destination of an assignment: + update the environment along the paths, end the borrows and loans at + this place, etc. + + Return the updated context and the (updated) value at the end of the + place. This value should not contain any loan or borrow (and we check + it is the case). Note that it is very likely to contain [Bottom] values. + *) +let prepare_lplace (config : C.config) (p : E.place) (ctx : C.eval_ctx) : + C.eval_ctx * V.typed_value = + (* TODO *) + let access = Write in + let ctx = update_ctx_along_write_place config access p ctx in + (* End the borrows and loans, starting with the borrows *) + let ctx = drop_borrows_loans_at_lplace config p ctx in + (* Read the value and check it *) + let v = read_place_unwrap config access p ctx in + (* Sanity checks *) + assert (not (loans_in_value v)); + assert (not (borrows_in_value v)); + (* Return *) + (ctx, v) + +(** Read the value at a given place. + As long as it is a loan, end the loan. + This function doesn't perform a recursive exploration: + it won't dive into the value to end all the inner + loans (contrary to [drop_borrows_loans_at_lplace] for + instance). + *) +let rec end_loan_exactly_at_place (config : C.config) (access : access_kind) + (p : E.place) (ctx : C.eval_ctx) : C.eval_ctx = + let v = read_place_unwrap config access p ctx in + match v.V.value with + | V.Loan (V.SharedLoan (bids, _)) -> + let ctx = end_outer_borrows config bids ctx in + end_loan_exactly_at_place config access p ctx + | V.Loan (V.MutLoan bid) -> + let ctx = end_outer_borrow config bid ctx in + end_loan_exactly_at_place config access p ctx + | _ -> ctx -- cgit v1.2.3 From ec719bee1abca9274a0ca5d6dcf4b8947a71a506 Mon Sep 17 00:00:00 2001 From: Son Ho Date: Thu, 6 Jan 2022 10:38:30 +0100 Subject: Move some functions from Interpreter to InterpreterExpressions --- src/Interpreter.ml | 438 +------------------------------------- src/InterpreterExpressions.ml | 476 ++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 477 insertions(+), 437 deletions(-) create mode 100644 src/InterpreterExpressions.ml (limited to 'src') diff --git a/src/Interpreter.ml b/src/Interpreter.ml index 4ca7d58f..73967f61 100644 --- a/src/Interpreter.ml +++ b/src/Interpreter.ml @@ -17,6 +17,7 @@ open InterpreterProjectors open InterpreterBorrows open InterpreterExpansion open InterpreterPaths +open InterpreterExpressions (* TODO: check that the value types are correct when evaluating *) (* TODO: for debugging purposes, we might want to put use eval_ctx everywhere @@ -33,443 +34,6 @@ open InterpreterPaths (* TODO: remove the config parameters when they are useless *) -(** TODO: change the name *) -type eval_error = Panic - -type 'a eval_result = ('a, eval_error) result - -(** Convert a constant operand value to a typed value *) -let constant_value_to_typed_value (ctx : C.eval_ctx) (ty : T.ety) - (cv : E.operand_constant_value) : V.typed_value = - (* Check the type while converting *) - match (ty, cv) with - (* Unit *) - | T.Adt (T.Tuple, [], []), Unit -> mk_unit_value - (* Adt with one variant and no fields *) - | T.Adt (T.AdtId def_id, [], []), ConstantAdt def_id' -> - assert (def_id = def_id'); - (* Check that the adt definition only has one variant with no fields, - compute the variant id at the same time. *) - let def = C.ctx_lookup_type_def ctx def_id in - assert (List.length def.region_params = 0); - assert (List.length def.type_params = 0); - let variant_id = - match def.kind with - | Struct fields -> - assert (List.length fields = 0); - None - | Enum variants -> - assert (List.length variants = 1); - let variant_id = T.VariantId.zero in - let variant = T.VariantId.nth variants variant_id in - assert (List.length variant.fields = 0); - Some variant_id - in - let value = V.Adt { variant_id; field_values = [] } in - { value; ty } - (* Scalar, boolean... *) - | T.Bool, ConstantValue (Bool v) -> { V.value = V.Concrete (Bool v); ty } - | T.Char, ConstantValue (Char v) -> { V.value = V.Concrete (Char v); ty } - | T.Str, ConstantValue (String v) -> { V.value = V.Concrete (String v); ty } - | T.Integer int_ty, ConstantValue (V.Scalar v) -> - (* Check the type and the ranges *) - assert (int_ty == v.int_ty); - assert (check_scalar_value_in_range v); - { V.value = V.Concrete (V.Scalar v); ty } - (* Remaining cases (invalid) - listing as much as we can on purpose - (allows to catch errors at compilation if the definitions change) *) - | _, Unit | _, ConstantAdt _ | _, ConstantValue _ -> - failwith "Improperly typed constant value" - -(** Small utility *) -let prepare_rplace (config : C.config) (access : access_kind) (p : E.place) - (ctx : C.eval_ctx) : C.eval_ctx * V.typed_value = - let ctx = update_ctx_along_read_place config access p ctx in - let ctx = end_loans_at_place config access p ctx in - let v = read_place_unwrap config access p ctx in - (ctx, v) - -(** Prepare the evaluation of an operand. *) -let eval_operand_prepare (config : C.config) (ctx : C.eval_ctx) (op : E.operand) - : C.eval_ctx * V.typed_value = - let ctx, v = - match op with - | Expressions.Constant (ty, cv) -> - let v = constant_value_to_typed_value ctx ty cv in - (ctx, v) - | Expressions.Copy p -> - (* Access the value *) - let access = Read in - prepare_rplace config access p ctx - | Expressions.Move p -> - (* Access the value *) - let access = Move in - prepare_rplace config access p ctx - in - assert (not (bottom_in_value v)); - (ctx, v) - -(** Evaluate an operand. *) -let eval_operand (config : C.config) (ctx : C.eval_ctx) (op : E.operand) : - C.eval_ctx * V.typed_value = - (* Debug *) - L.log#ldebug - (lazy - ("eval_operand:\n- ctx:\n" ^ eval_ctx_to_string ctx ^ "\n\n- op:\n" - ^ operand_to_string ctx op ^ "\n")); - (* Evaluate *) - match op with - | Expressions.Constant (ty, cv) -> - let v = constant_value_to_typed_value ctx ty cv in - (ctx, v) - | Expressions.Copy p -> - (* Access the value *) - let access = Read in - let ctx, v = prepare_rplace config access p ctx in - (* Copy the value *) - L.log#ldebug (lazy ("Value to copy:\n" ^ typed_value_to_string ctx v)); - assert (not (bottom_in_value v)); - let allow_adt_copy = false in - copy_value allow_adt_copy config ctx v - | Expressions.Move p -> ( - (* Access the value *) - let access = Move in - let ctx, v = prepare_rplace config access p ctx in - (* Move the value *) - L.log#ldebug (lazy ("Value to move:\n" ^ typed_value_to_string ctx v)); - assert (not (bottom_in_value v)); - let bottom : V.typed_value = { V.value = Bottom; ty = v.ty } in - match write_place config access p bottom ctx with - | Error _ -> failwith "Unreachable" - | Ok ctx -> (ctx, v)) - -(** Evaluate several operands. *) -let eval_operands (config : C.config) (ctx : C.eval_ctx) (ops : E.operand list) - : C.eval_ctx * V.typed_value list = - List.fold_left_map (fun ctx op -> eval_operand config ctx op) ctx ops - -let eval_two_operands (config : C.config) (ctx : C.eval_ctx) (op1 : E.operand) - (op2 : E.operand) : C.eval_ctx * V.typed_value * V.typed_value = - match eval_operands config ctx [ op1; op2 ] with - | ctx, [ v1; v2 ] -> (ctx, v1, v2) - | _ -> failwith "Unreachable" - -let eval_unary_op_concrete (config : C.config) (ctx : C.eval_ctx) - (unop : E.unop) (op : E.operand) : (C.eval_ctx * V.typed_value) eval_result - = - (* Evaluate the operand *) - let ctx, v = eval_operand config ctx op in - (* Apply the unop *) - match (unop, v.V.value) with - | E.Not, V.Concrete (Bool b) -> - Ok (ctx, { v with V.value = V.Concrete (Bool (not b)) }) - | E.Neg, V.Concrete (V.Scalar sv) -> ( - let i = Z.neg sv.V.value in - match mk_scalar sv.int_ty i with - | Error _ -> Error Panic - | Ok sv -> Ok (ctx, { v with V.value = V.Concrete (V.Scalar sv) })) - | _ -> failwith "Invalid input for unop" - -let eval_unary_op_symbolic (config : C.config) (ctx : C.eval_ctx) - (unop : E.unop) (op : E.operand) : (C.eval_ctx * V.typed_value) eval_result - = - (* Evaluate the operand *) - let ctx, v = eval_operand config ctx op in - (* Generate a fresh symbolic value to store the result *) - let ctx, res_sv_id = C.fresh_symbolic_value_id ctx in - let res_sv_ty = - match (unop, v.V.ty) with - | E.Not, T.Bool -> T.Bool - | E.Neg, T.Integer int_ty -> T.Integer int_ty - | _ -> failwith "Invalid input for unop" - in - let res_sv = { V.sv_id = res_sv_id; sv_ty = res_sv_ty } in - (* Synthesize *) - S.synthesize_unary_op unop v res_sv; - (* Return *) - Ok (ctx, mk_typed_value_from_symbolic_value res_sv) - -let eval_unary_op (config : C.config) (ctx : C.eval_ctx) (unop : E.unop) - (op : E.operand) : (C.eval_ctx * V.typed_value) eval_result = - match config.mode with - | C.ConcreteMode -> eval_unary_op_concrete config ctx unop op - | C.SymbolicMode -> eval_unary_op_symbolic config ctx unop op - -let eval_binary_op_concrete (config : C.config) (ctx : C.eval_ctx) - (binop : E.binop) (op1 : E.operand) (op2 : E.operand) : - (C.eval_ctx * V.typed_value) eval_result = - (* Evaluate the operands *) - let ctx, v1, v2 = eval_two_operands config ctx op1 op2 in - (* Equality check binops (Eq, Ne) accept values from a wide variety of types. - * The remaining binops only operate on scalars. *) - if binop = Eq || binop = Ne then ( - (* Equality operations *) - assert (v1.ty = v2.ty); - (* Equality/inequality check is primitive only for a subset of types *) - assert (type_is_primitively_copyable v1.ty); - let b = v1 = v2 in - Ok (ctx, { V.value = V.Concrete (Bool b); ty = T.Bool })) - else - (* For the non-equality operations, the input values are necessarily scalars *) - match (v1.V.value, v2.V.value) with - | V.Concrete (V.Scalar sv1), V.Concrete (V.Scalar sv2) -> ( - let res = - (* There are binops which require the two operands to have the same - type, and binops for which it is not the case. - There are also binops which return booleans, and binops which - return integers. - *) - match binop with - | E.Lt | E.Le | E.Ge | E.Gt -> - (* The two operands must have the same type and the result is a boolean *) - assert (sv1.int_ty = sv2.int_ty); - let b = - match binop with - | E.Lt -> Z.lt sv1.V.value sv2.V.value - | E.Le -> Z.leq sv1.V.value sv2.V.value - | E.Ge -> Z.geq sv1.V.value sv2.V.value - | E.Gt -> Z.gt sv1.V.value sv2.V.value - | E.Div | E.Rem | E.Add | E.Sub | E.Mul | E.BitXor | E.BitAnd - | E.BitOr | E.Shl | E.Shr | E.Ne | E.Eq -> - failwith "Unreachable" - in - Ok - ({ V.value = V.Concrete (Bool b); ty = T.Bool } : V.typed_value) - | E.Div | E.Rem | E.Add | E.Sub | E.Mul | E.BitXor | E.BitAnd - | E.BitOr -> ( - (* The two operands must have the same type and the result is an integer *) - assert (sv1.int_ty = sv2.int_ty); - let res = - match binop with - | E.Div -> - if sv2.V.value = Z.zero then Error () - else mk_scalar sv1.int_ty (Z.div sv1.V.value sv2.V.value) - | E.Rem -> - (* See [https://github.com/ocaml/Zarith/blob/master/z.mli] *) - if sv2.V.value = Z.zero then Error () - else mk_scalar sv1.int_ty (Z.rem sv1.V.value sv2.V.value) - | E.Add -> mk_scalar sv1.int_ty (Z.add sv1.V.value sv2.V.value) - | E.Sub -> mk_scalar sv1.int_ty (Z.sub sv1.V.value sv2.V.value) - | E.Mul -> mk_scalar sv1.int_ty (Z.mul sv1.V.value sv2.V.value) - | E.BitXor -> raise Unimplemented - | E.BitAnd -> raise Unimplemented - | E.BitOr -> raise Unimplemented - | E.Lt | E.Le | E.Ge | E.Gt | E.Shl | E.Shr | E.Ne | E.Eq -> - failwith "Unreachable" - in - match res with - | Error err -> Error err - | Ok sv -> - Ok - { - V.value = V.Concrete (V.Scalar sv); - ty = Integer sv1.int_ty; - }) - | E.Shl | E.Shr -> raise Unimplemented - | E.Ne | E.Eq -> failwith "Unreachable" - in - match res with Error _ -> Error Panic | Ok v -> Ok (ctx, v)) - | _ -> failwith "Invalid inputs for binop" - -let eval_binary_op_symbolic (config : C.config) (ctx : C.eval_ctx) - (binop : E.binop) (op1 : E.operand) (op2 : E.operand) : - (C.eval_ctx * V.typed_value) eval_result = - (* Evaluate the operands *) - let ctx, v1, v2 = eval_two_operands config ctx op1 op2 in - (* Generate a fresh symbolic value to store the result *) - let ctx, res_sv_id = C.fresh_symbolic_value_id ctx in - let res_sv_ty = - if binop = Eq || binop = Ne then ( - (* Equality operations *) - assert (v1.ty = v2.ty); - (* Equality/inequality check is primitive only for a subset of types *) - assert (type_is_primitively_copyable v1.ty); - T.Bool) - else - (* Other operations: input types are integers *) - match (v1.V.ty, v2.V.ty) with - | T.Integer int_ty1, T.Integer int_ty2 -> ( - match binop with - | E.Lt | E.Le | E.Ge | E.Gt -> - assert (int_ty1 = int_ty2); - T.Bool - | E.Div | E.Rem | E.Add | E.Sub | E.Mul | E.BitXor | E.BitAnd - | E.BitOr -> - assert (int_ty1 = int_ty2); - T.Integer int_ty1 - | E.Shl | E.Shr -> raise Unimplemented - | E.Ne | E.Eq -> failwith "Unreachable") - | _ -> failwith "Invalid inputs for binop" - in - let res_sv = { V.sv_id = res_sv_id; sv_ty = res_sv_ty } in - (* Synthesize *) - S.synthesize_binary_op binop v1 v2 res_sv; - (* Return *) - Ok (ctx, mk_typed_value_from_symbolic_value res_sv) - -let eval_binary_op (config : C.config) (ctx : C.eval_ctx) (binop : E.binop) - (op1 : E.operand) (op2 : E.operand) : - (C.eval_ctx * V.typed_value) eval_result = - match config.mode with - | C.ConcreteMode -> eval_binary_op_concrete config ctx binop op1 op2 - | C.SymbolicMode -> eval_binary_op_symbolic config ctx binop op1 op2 - -(** Evaluate the discriminant of a concrete (i.e., non symbolic) ADT value *) -let eval_rvalue_discriminant_concrete (config : C.config) (p : E.place) - (ctx : C.eval_ctx) : C.eval_ctx * V.typed_value = - (* Note that discriminant values have type `isize` *) - (* Access the value *) - let access = Read in - let ctx, v = prepare_rplace config access p ctx in - match v.V.value with - | Adt av -> ( - match av.variant_id with - | None -> - failwith "Invalid input for `discriminant`: structure instead of enum" - | Some variant_id -> ( - let id = Z.of_int (T.VariantId.to_int variant_id) in - match mk_scalar Isize id with - | Error _ -> - failwith "Disciminant id out of range" - (* Should really never happen *) - | Ok sv -> - (ctx, { V.value = V.Concrete (V.Scalar sv); ty = Integer Isize })) - ) - | _ -> failwith "Invalid input for `discriminant`" - -let eval_rvalue_discriminant (config : C.config) (p : E.place) - (ctx : C.eval_ctx) : (C.eval_ctx * V.typed_value) list = - S.synthesize_eval_rvalue_discriminant p; - (* Note that discriminant values have type `isize` *) - (* Access the value *) - let access = Read in - let ctx, v = prepare_rplace config access p ctx in - match v.V.value with - | Adt _ -> [ eval_rvalue_discriminant_concrete config p ctx ] - | Symbolic sv -> - (* Expand the symbolic value - may lead to branching *) - let ctxl = expand_symbolic_enum_value config sv ctx in - (* This time the value is concrete: reevaluate *) - List.map (eval_rvalue_discriminant_concrete config p) ctxl - | _ -> failwith "Invalid input for `discriminant`" - -let eval_rvalue_ref (config : C.config) (ctx : C.eval_ctx) (p : E.place) - (bkind : E.borrow_kind) : C.eval_ctx * V.typed_value = - S.synthesize_eval_rvalue_ref p bkind; - match bkind with - | E.Shared | E.TwoPhaseMut -> - (* Access the value *) - let access = if bkind = E.Shared then Read else Write in - let ctx, v = prepare_rplace config access p ctx in - (* Compute the rvalue - simply a shared borrow with a fresh id *) - let ctx, bid = C.fresh_borrow_id ctx in - (* Note that the reference is *mutable* if we do a two-phase borrow *) - let rv_ty = - T.Ref (T.Erased, v.ty, if bkind = E.Shared then Shared else Mut) - in - let bc = - if bkind = E.Shared then V.SharedBorrow bid - else V.InactivatedMutBorrow bid - in - let rv : V.typed_value = { V.value = V.Borrow bc; ty = rv_ty } in - (* Compute the value with which to replace the value at place p *) - let nv = - match v.V.value with - | V.Loan (V.SharedLoan (bids, sv)) -> - (* Shared loan: insert the new borrow id *) - let bids1 = V.BorrowId.Set.add bid bids in - { v with V.value = V.Loan (V.SharedLoan (bids1, sv)) } - | _ -> - (* Not a shared loan: add a wrapper *) - let v' = V.Loan (V.SharedLoan (V.BorrowId.Set.singleton bid, v)) in - { v with V.value = v' } - in - (* Update the value in the context *) - let ctx = write_place_unwrap config access p nv ctx in - (* Return *) - (ctx, rv) - | E.Mut -> - (* Access the value *) - let access = Write in - let ctx, v = prepare_rplace config access p ctx in - (* Compute the rvalue - wrap the value in a mutable borrow with a fresh id *) - let ctx, bid = C.fresh_borrow_id ctx in - let rv_ty = T.Ref (T.Erased, v.ty, Mut) in - let rv : V.typed_value = - { V.value = V.Borrow (V.MutBorrow (bid, v)); ty = rv_ty } - in - (* Compute the value with which to replace the value at place p *) - let nv = { v with V.value = V.Loan (V.MutLoan bid) } in - (* Update the value in the context *) - let ctx = write_place_unwrap config access p nv ctx in - (* Return *) - (ctx, rv) - -let eval_rvalue_aggregate (config : C.config) (ctx : C.eval_ctx) - (aggregate_kind : E.aggregate_kind) (ops : E.operand list) : - C.eval_ctx * V.typed_value = - S.synthesize_eval_rvalue_aggregate aggregate_kind ops; - (* Evaluate the operands *) - let ctx, values = eval_operands config ctx ops in - (* Match on the aggregate kind *) - match aggregate_kind with - | E.AggregatedTuple -> - let tys = List.map (fun (v : V.typed_value) -> v.V.ty) values in - let v = V.Adt { variant_id = None; field_values = values } in - let ty = T.Adt (T.Tuple, [], tys) in - (ctx, { V.value = v; ty }) - | E.AggregatedAdt (def_id, opt_variant_id, regions, types) -> - (* Sanity checks *) - let type_def = C.ctx_lookup_type_def ctx def_id in - assert (List.length type_def.region_params = List.length regions); - let expected_field_types = - Subst.ctx_adt_get_instantiated_field_etypes ctx def_id opt_variant_id - types - in - assert ( - expected_field_types - = List.map (fun (v : V.typed_value) -> v.V.ty) values); - (* Construct the value *) - let av : V.adt_value = - { V.variant_id = opt_variant_id; V.field_values = values } - in - let aty = T.Adt (T.AdtId def_id, regions, types) in - (ctx, { V.value = Adt av; ty = aty }) - -(** Evaluate an rvalue which is not a discriminant. - - We define a function for this specific case, because evaluating - a discriminant might lead to branching (if we evaluate the discriminant - of a symbolic enumeration value), while it is not the case for the - other rvalues. - *) -let eval_rvalue_non_discriminant (config : C.config) (ctx : C.eval_ctx) - (rvalue : E.rvalue) : (C.eval_ctx * V.typed_value) eval_result = - match rvalue with - | E.Use op -> Ok (eval_operand config ctx op) - | E.Ref (p, bkind) -> Ok (eval_rvalue_ref config ctx p bkind) - | E.UnaryOp (unop, op) -> eval_unary_op config ctx unop op - | E.BinaryOp (binop, op1, op2) -> eval_binary_op config ctx binop op1 op2 - | E.Aggregate (aggregate_kind, ops) -> - Ok (eval_rvalue_aggregate config ctx aggregate_kind ops) - | E.Discriminant _ -> failwith "Unreachable" - -(** Evaluate an rvalue in a given context: return the updated context and - the computed value. - - Returns a list of pairs (new context, computed rvalue) because - `discriminant` might lead to a branching in case it is applied - on a symbolic enumeration value. -*) -let eval_rvalue (config : C.config) (ctx : C.eval_ctx) (rvalue : E.rvalue) : - (C.eval_ctx * V.typed_value) list eval_result = - match rvalue with - | E.Discriminant p -> Ok (eval_rvalue_discriminant config p ctx) - | _ -> ( - match eval_rvalue_non_discriminant config ctx rvalue with - | Error e -> Error e - | Ok res -> Ok [ res ]) - (** Result of evaluating a statement *) type statement_eval_res = Unit | Break of int | Continue of int | Return diff --git a/src/InterpreterExpressions.ml b/src/InterpreterExpressions.ml new file mode 100644 index 00000000..41eda802 --- /dev/null +++ b/src/InterpreterExpressions.ml @@ -0,0 +1,476 @@ +module T = Types +module V = Values +open Scalars +module E = Expressions +open Errors +module C = Contexts +module Subst = Substitute +module A = CfimAst +module L = Logging +open TypesUtils +open ValuesUtils +module Inv = Invariants +module S = Synthesis +open Utils +open InterpreterUtils +open InterpreterProjectors +open InterpreterBorrows +open InterpreterExpansion +open InterpreterPaths + +(** TODO: change the name *) +type eval_error = Panic + +type 'a eval_result = ('a, eval_error) result + +(** Convert a constant operand value to a typed value *) +let constant_value_to_typed_value (ctx : C.eval_ctx) (ty : T.ety) + (cv : E.operand_constant_value) : V.typed_value = + (* Check the type while converting *) + match (ty, cv) with + (* Unit *) + | T.Adt (T.Tuple, [], []), Unit -> mk_unit_value + (* Adt with one variant and no fields *) + | T.Adt (T.AdtId def_id, [], []), ConstantAdt def_id' -> + assert (def_id = def_id'); + (* Check that the adt definition only has one variant with no fields, + compute the variant id at the same time. *) + let def = C.ctx_lookup_type_def ctx def_id in + assert (List.length def.region_params = 0); + assert (List.length def.type_params = 0); + let variant_id = + match def.kind with + | Struct fields -> + assert (List.length fields = 0); + None + | Enum variants -> + assert (List.length variants = 1); + let variant_id = T.VariantId.zero in + let variant = T.VariantId.nth variants variant_id in + assert (List.length variant.fields = 0); + Some variant_id + in + let value = V.Adt { variant_id; field_values = [] } in + { value; ty } + (* Scalar, boolean... *) + | T.Bool, ConstantValue (Bool v) -> { V.value = V.Concrete (Bool v); ty } + | T.Char, ConstantValue (Char v) -> { V.value = V.Concrete (Char v); ty } + | T.Str, ConstantValue (String v) -> { V.value = V.Concrete (String v); ty } + | T.Integer int_ty, ConstantValue (V.Scalar v) -> + (* Check the type and the ranges *) + assert (int_ty == v.int_ty); + assert (check_scalar_value_in_range v); + { V.value = V.Concrete (V.Scalar v); ty } + (* Remaining cases (invalid) - listing as much as we can on purpose + (allows to catch errors at compilation if the definitions change) *) + | _, Unit | _, ConstantAdt _ | _, ConstantValue _ -> + failwith "Improperly typed constant value" + +(** Small utility *) +let prepare_rplace (config : C.config) (access : access_kind) (p : E.place) + (ctx : C.eval_ctx) : C.eval_ctx * V.typed_value = + let ctx = update_ctx_along_read_place config access p ctx in + let ctx = end_loans_at_place config access p ctx in + let v = read_place_unwrap config access p ctx in + (ctx, v) + +(** Prepare the evaluation of an operand. *) +let eval_operand_prepare (config : C.config) (ctx : C.eval_ctx) (op : E.operand) + : C.eval_ctx * V.typed_value = + let ctx, v = + match op with + | Expressions.Constant (ty, cv) -> + let v = constant_value_to_typed_value ctx ty cv in + (ctx, v) + | Expressions.Copy p -> + (* Access the value *) + let access = Read in + prepare_rplace config access p ctx + | Expressions.Move p -> + (* Access the value *) + let access = Move in + prepare_rplace config access p ctx + in + assert (not (bottom_in_value v)); + (ctx, v) + +(** Evaluate an operand. *) +let eval_operand (config : C.config) (ctx : C.eval_ctx) (op : E.operand) : + C.eval_ctx * V.typed_value = + (* Debug *) + L.log#ldebug + (lazy + ("eval_operand:\n- ctx:\n" ^ eval_ctx_to_string ctx ^ "\n\n- op:\n" + ^ operand_to_string ctx op ^ "\n")); + (* Evaluate *) + match op with + | Expressions.Constant (ty, cv) -> + let v = constant_value_to_typed_value ctx ty cv in + (ctx, v) + | Expressions.Copy p -> + (* Access the value *) + let access = Read in + let ctx, v = prepare_rplace config access p ctx in + (* Copy the value *) + L.log#ldebug (lazy ("Value to copy:\n" ^ typed_value_to_string ctx v)); + assert (not (bottom_in_value v)); + let allow_adt_copy = false in + copy_value allow_adt_copy config ctx v + | Expressions.Move p -> ( + (* Access the value *) + let access = Move in + let ctx, v = prepare_rplace config access p ctx in + (* Move the value *) + L.log#ldebug (lazy ("Value to move:\n" ^ typed_value_to_string ctx v)); + assert (not (bottom_in_value v)); + let bottom : V.typed_value = { V.value = Bottom; ty = v.ty } in + match write_place config access p bottom ctx with + | Error _ -> failwith "Unreachable" + | Ok ctx -> (ctx, v)) + +(** Evaluate several operands. *) +let eval_operands (config : C.config) (ctx : C.eval_ctx) (ops : E.operand list) + : C.eval_ctx * V.typed_value list = + List.fold_left_map (fun ctx op -> eval_operand config ctx op) ctx ops + +let eval_two_operands (config : C.config) (ctx : C.eval_ctx) (op1 : E.operand) + (op2 : E.operand) : C.eval_ctx * V.typed_value * V.typed_value = + match eval_operands config ctx [ op1; op2 ] with + | ctx, [ v1; v2 ] -> (ctx, v1, v2) + | _ -> failwith "Unreachable" + +let eval_unary_op_concrete (config : C.config) (ctx : C.eval_ctx) + (unop : E.unop) (op : E.operand) : (C.eval_ctx * V.typed_value) eval_result + = + (* Evaluate the operand *) + let ctx, v = eval_operand config ctx op in + (* Apply the unop *) + match (unop, v.V.value) with + | E.Not, V.Concrete (Bool b) -> + Ok (ctx, { v with V.value = V.Concrete (Bool (not b)) }) + | E.Neg, V.Concrete (V.Scalar sv) -> ( + let i = Z.neg sv.V.value in + match mk_scalar sv.int_ty i with + | Error _ -> Error Panic + | Ok sv -> Ok (ctx, { v with V.value = V.Concrete (V.Scalar sv) })) + | _ -> failwith "Invalid input for unop" + +let eval_unary_op_symbolic (config : C.config) (ctx : C.eval_ctx) + (unop : E.unop) (op : E.operand) : (C.eval_ctx * V.typed_value) eval_result + = + (* Evaluate the operand *) + let ctx, v = eval_operand config ctx op in + (* Generate a fresh symbolic value to store the result *) + let ctx, res_sv_id = C.fresh_symbolic_value_id ctx in + let res_sv_ty = + match (unop, v.V.ty) with + | E.Not, T.Bool -> T.Bool + | E.Neg, T.Integer int_ty -> T.Integer int_ty + | _ -> failwith "Invalid input for unop" + in + let res_sv = { V.sv_id = res_sv_id; sv_ty = res_sv_ty } in + (* Synthesize *) + S.synthesize_unary_op unop v res_sv; + (* Return *) + Ok (ctx, mk_typed_value_from_symbolic_value res_sv) + +let eval_unary_op (config : C.config) (ctx : C.eval_ctx) (unop : E.unop) + (op : E.operand) : (C.eval_ctx * V.typed_value) eval_result = + match config.mode with + | C.ConcreteMode -> eval_unary_op_concrete config ctx unop op + | C.SymbolicMode -> eval_unary_op_symbolic config ctx unop op + +let eval_binary_op_concrete (config : C.config) (ctx : C.eval_ctx) + (binop : E.binop) (op1 : E.operand) (op2 : E.operand) : + (C.eval_ctx * V.typed_value) eval_result = + (* Evaluate the operands *) + let ctx, v1, v2 = eval_two_operands config ctx op1 op2 in + (* Equality check binops (Eq, Ne) accept values from a wide variety of types. + * The remaining binops only operate on scalars. *) + if binop = Eq || binop = Ne then ( + (* Equality operations *) + assert (v1.ty = v2.ty); + (* Equality/inequality check is primitive only for a subset of types *) + assert (type_is_primitively_copyable v1.ty); + let b = v1 = v2 in + Ok (ctx, { V.value = V.Concrete (Bool b); ty = T.Bool })) + else + (* For the non-equality operations, the input values are necessarily scalars *) + match (v1.V.value, v2.V.value) with + | V.Concrete (V.Scalar sv1), V.Concrete (V.Scalar sv2) -> ( + let res = + (* There are binops which require the two operands to have the same + type, and binops for which it is not the case. + There are also binops which return booleans, and binops which + return integers. + *) + match binop with + | E.Lt | E.Le | E.Ge | E.Gt -> + (* The two operands must have the same type and the result is a boolean *) + assert (sv1.int_ty = sv2.int_ty); + let b = + match binop with + | E.Lt -> Z.lt sv1.V.value sv2.V.value + | E.Le -> Z.leq sv1.V.value sv2.V.value + | E.Ge -> Z.geq sv1.V.value sv2.V.value + | E.Gt -> Z.gt sv1.V.value sv2.V.value + | E.Div | E.Rem | E.Add | E.Sub | E.Mul | E.BitXor | E.BitAnd + | E.BitOr | E.Shl | E.Shr | E.Ne | E.Eq -> + failwith "Unreachable" + in + Ok + ({ V.value = V.Concrete (Bool b); ty = T.Bool } : V.typed_value) + | E.Div | E.Rem | E.Add | E.Sub | E.Mul | E.BitXor | E.BitAnd + | E.BitOr -> ( + (* The two operands must have the same type and the result is an integer *) + assert (sv1.int_ty = sv2.int_ty); + let res = + match binop with + | E.Div -> + if sv2.V.value = Z.zero then Error () + else mk_scalar sv1.int_ty (Z.div sv1.V.value sv2.V.value) + | E.Rem -> + (* See [https://github.com/ocaml/Zarith/blob/master/z.mli] *) + if sv2.V.value = Z.zero then Error () + else mk_scalar sv1.int_ty (Z.rem sv1.V.value sv2.V.value) + | E.Add -> mk_scalar sv1.int_ty (Z.add sv1.V.value sv2.V.value) + | E.Sub -> mk_scalar sv1.int_ty (Z.sub sv1.V.value sv2.V.value) + | E.Mul -> mk_scalar sv1.int_ty (Z.mul sv1.V.value sv2.V.value) + | E.BitXor -> raise Unimplemented + | E.BitAnd -> raise Unimplemented + | E.BitOr -> raise Unimplemented + | E.Lt | E.Le | E.Ge | E.Gt | E.Shl | E.Shr | E.Ne | E.Eq -> + failwith "Unreachable" + in + match res with + | Error err -> Error err + | Ok sv -> + Ok + { + V.value = V.Concrete (V.Scalar sv); + ty = Integer sv1.int_ty; + }) + | E.Shl | E.Shr -> raise Unimplemented + | E.Ne | E.Eq -> failwith "Unreachable" + in + match res with Error _ -> Error Panic | Ok v -> Ok (ctx, v)) + | _ -> failwith "Invalid inputs for binop" + +let eval_binary_op_symbolic (config : C.config) (ctx : C.eval_ctx) + (binop : E.binop) (op1 : E.operand) (op2 : E.operand) : + (C.eval_ctx * V.typed_value) eval_result = + (* Evaluate the operands *) + let ctx, v1, v2 = eval_two_operands config ctx op1 op2 in + (* Generate a fresh symbolic value to store the result *) + let ctx, res_sv_id = C.fresh_symbolic_value_id ctx in + let res_sv_ty = + if binop = Eq || binop = Ne then ( + (* Equality operations *) + assert (v1.ty = v2.ty); + (* Equality/inequality check is primitive only for a subset of types *) + assert (type_is_primitively_copyable v1.ty); + T.Bool) + else + (* Other operations: input types are integers *) + match (v1.V.ty, v2.V.ty) with + | T.Integer int_ty1, T.Integer int_ty2 -> ( + match binop with + | E.Lt | E.Le | E.Ge | E.Gt -> + assert (int_ty1 = int_ty2); + T.Bool + | E.Div | E.Rem | E.Add | E.Sub | E.Mul | E.BitXor | E.BitAnd + | E.BitOr -> + assert (int_ty1 = int_ty2); + T.Integer int_ty1 + | E.Shl | E.Shr -> raise Unimplemented + | E.Ne | E.Eq -> failwith "Unreachable") + | _ -> failwith "Invalid inputs for binop" + in + let res_sv = { V.sv_id = res_sv_id; sv_ty = res_sv_ty } in + (* Synthesize *) + S.synthesize_binary_op binop v1 v2 res_sv; + (* Return *) + Ok (ctx, mk_typed_value_from_symbolic_value res_sv) + +let eval_binary_op (config : C.config) (ctx : C.eval_ctx) (binop : E.binop) + (op1 : E.operand) (op2 : E.operand) : + (C.eval_ctx * V.typed_value) eval_result = + match config.mode with + | C.ConcreteMode -> eval_binary_op_concrete config ctx binop op1 op2 + | C.SymbolicMode -> eval_binary_op_symbolic config ctx binop op1 op2 + +(** Evaluate the discriminant of a concrete (i.e., non symbolic) ADT value *) +let eval_rvalue_discriminant_concrete (config : C.config) (p : E.place) + (ctx : C.eval_ctx) : C.eval_ctx * V.typed_value = + (* Note that discriminant values have type `isize` *) + (* Access the value *) + let access = Read in + let ctx, v = prepare_rplace config access p ctx in + match v.V.value with + | Adt av -> ( + match av.variant_id with + | None -> + failwith "Invalid input for `discriminant`: structure instead of enum" + | Some variant_id -> ( + let id = Z.of_int (T.VariantId.to_int variant_id) in + match mk_scalar Isize id with + | Error _ -> + failwith "Disciminant id out of range" + (* Should really never happen *) + | Ok sv -> + (ctx, { V.value = V.Concrete (V.Scalar sv); ty = Integer Isize })) + ) + | _ -> failwith "Invalid input for `discriminant`" + +let eval_rvalue_discriminant (config : C.config) (p : E.place) + (ctx : C.eval_ctx) : (C.eval_ctx * V.typed_value) list = + S.synthesize_eval_rvalue_discriminant p; + (* Note that discriminant values have type `isize` *) + (* Access the value *) + let access = Read in + let ctx, v = prepare_rplace config access p ctx in + match v.V.value with + | Adt _ -> [ eval_rvalue_discriminant_concrete config p ctx ] + | Symbolic sv -> + (* Expand the symbolic value - may lead to branching *) + let ctxl = expand_symbolic_enum_value config sv ctx in + (* This time the value is concrete: reevaluate *) + List.map (eval_rvalue_discriminant_concrete config p) ctxl + | _ -> failwith "Invalid input for `discriminant`" + +let eval_rvalue_ref (config : C.config) (ctx : C.eval_ctx) (p : E.place) + (bkind : E.borrow_kind) : C.eval_ctx * V.typed_value = + S.synthesize_eval_rvalue_ref p bkind; + match bkind with + | E.Shared | E.TwoPhaseMut -> + (* Access the value *) + let access = if bkind = E.Shared then Read else Write in + let ctx, v = prepare_rplace config access p ctx in + (* Compute the rvalue - simply a shared borrow with a fresh id *) + let ctx, bid = C.fresh_borrow_id ctx in + (* Note that the reference is *mutable* if we do a two-phase borrow *) + let rv_ty = + T.Ref (T.Erased, v.ty, if bkind = E.Shared then Shared else Mut) + in + let bc = + if bkind = E.Shared then V.SharedBorrow bid + else V.InactivatedMutBorrow bid + in + let rv : V.typed_value = { V.value = V.Borrow bc; ty = rv_ty } in + (* Compute the value with which to replace the value at place p *) + let nv = + match v.V.value with + | V.Loan (V.SharedLoan (bids, sv)) -> + (* Shared loan: insert the new borrow id *) + let bids1 = V.BorrowId.Set.add bid bids in + { v with V.value = V.Loan (V.SharedLoan (bids1, sv)) } + | _ -> + (* Not a shared loan: add a wrapper *) + let v' = V.Loan (V.SharedLoan (V.BorrowId.Set.singleton bid, v)) in + { v with V.value = v' } + in + (* Update the value in the context *) + let ctx = write_place_unwrap config access p nv ctx in + (* Return *) + (ctx, rv) + | E.Mut -> + (* Access the value *) + let access = Write in + let ctx, v = prepare_rplace config access p ctx in + (* Compute the rvalue - wrap the value in a mutable borrow with a fresh id *) + let ctx, bid = C.fresh_borrow_id ctx in + let rv_ty = T.Ref (T.Erased, v.ty, Mut) in + let rv : V.typed_value = + { V.value = V.Borrow (V.MutBorrow (bid, v)); ty = rv_ty } + in + (* Compute the value with which to replace the value at place p *) + let nv = { v with V.value = V.Loan (V.MutLoan bid) } in + (* Update the value in the context *) + let ctx = write_place_unwrap config access p nv ctx in + (* Return *) + (ctx, rv) + +let eval_rvalue_aggregate (config : C.config) (ctx : C.eval_ctx) + (aggregate_kind : E.aggregate_kind) (ops : E.operand list) : + C.eval_ctx * V.typed_value = + S.synthesize_eval_rvalue_aggregate aggregate_kind ops; + (* Evaluate the operands *) + let ctx, values = eval_operands config ctx ops in + (* Match on the aggregate kind *) + match aggregate_kind with + | E.AggregatedTuple -> + let tys = List.map (fun (v : V.typed_value) -> v.V.ty) values in + let v = V.Adt { variant_id = None; field_values = values } in + let ty = T.Adt (T.Tuple, [], tys) in + (ctx, { V.value = v; ty }) + | E.AggregatedAdt (def_id, opt_variant_id, regions, types) -> + (* Sanity checks *) + let type_def = C.ctx_lookup_type_def ctx def_id in + assert (List.length type_def.region_params = List.length regions); + let expected_field_types = + Subst.ctx_adt_get_instantiated_field_etypes ctx def_id opt_variant_id + types + in + assert ( + expected_field_types + = List.map (fun (v : V.typed_value) -> v.V.ty) values); + (* Construct the value *) + let av : V.adt_value = + { V.variant_id = opt_variant_id; V.field_values = values } + in + let aty = T.Adt (T.AdtId def_id, regions, types) in + (ctx, { V.value = Adt av; ty = aty }) + +(** Evaluate an rvalue which is not a discriminant. + + We define a function for this specific case, because evaluating + a discriminant might lead to branching (if we evaluate the discriminant + of a symbolic enumeration value), while it is not the case for the + other rvalues. + *) +let eval_rvalue_non_discriminant (config : C.config) (ctx : C.eval_ctx) + (rvalue : E.rvalue) : (C.eval_ctx * V.typed_value) eval_result = + match rvalue with + | E.Use op -> Ok (eval_operand config ctx op) + | E.Ref (p, bkind) -> Ok (eval_rvalue_ref config ctx p bkind) + | E.UnaryOp (unop, op) -> eval_unary_op config ctx unop op + | E.BinaryOp (binop, op1, op2) -> eval_binary_op config ctx binop op1 op2 + | E.Aggregate (aggregate_kind, ops) -> + Ok (eval_rvalue_aggregate config ctx aggregate_kind ops) + | E.Discriminant _ -> failwith "Unreachable" + +(** Evaluate an rvalue in a given context: return the updated context and + the computed value. + + Returns a list of pairs (new context, computed rvalue) because + `discriminant` might lead to a branching in case it is applied + on a symbolic enumeration value. +*) +let eval_rvalue (config : C.config) (ctx : C.eval_ctx) (rvalue : E.rvalue) : + (C.eval_ctx * V.typed_value) list eval_result = + match rvalue with + | E.Discriminant p -> Ok (eval_rvalue_discriminant config p ctx) + | _ -> ( + match eval_rvalue_non_discriminant config ctx rvalue with + | Error e -> Error e + | Ok res -> Ok [ res ]) + +(** Drop a value at a given place *) +let drop_value (config : C.config) (ctx : C.eval_ctx) (p : E.place) : C.eval_ctx + = + L.log#ldebug (lazy ("drop_value: place: " ^ place_to_string ctx p)); + (* Prepare the place (by ending the loans, then the borrows) *) + let ctx, v = prepare_lplace config p ctx in + (* Replace the value with [Bottom] *) + let nv = { v with value = V.Bottom } in + let ctx = write_place_unwrap config Write p nv ctx in + ctx + +(** Assign a value to a given place *) +let assign_to_place (config : C.config) (ctx : C.eval_ctx) (v : V.typed_value) + (p : E.place) : C.eval_ctx = + (* Prepare the destination *) + let ctx, _ = prepare_lplace config p ctx in + (* Update the destination *) + let ctx = write_place_unwrap config Write p v ctx in + ctx -- cgit v1.2.3 From 70c6cbda0899bbf8783efcf55db02f74cffb4754 Mon Sep 17 00:00:00 2001 From: Son Ho Date: Thu, 6 Jan 2022 10:40:04 +0100 Subject: Move some definitions inside of InterpreterExpressions --- src/InterpreterExpressions.ml | 56 +++++++++++++++++++++---------------------- 1 file changed, 28 insertions(+), 28 deletions(-) (limited to 'src') diff --git a/src/InterpreterExpressions.ml b/src/InterpreterExpressions.ml index 41eda802..83651ba5 100644 --- a/src/InterpreterExpressions.ml +++ b/src/InterpreterExpressions.ml @@ -23,6 +23,34 @@ type eval_error = Panic type 'a eval_result = ('a, eval_error) result +(** Small utility *) +let prepare_rplace (config : C.config) (access : access_kind) (p : E.place) + (ctx : C.eval_ctx) : C.eval_ctx * V.typed_value = + let ctx = update_ctx_along_read_place config access p ctx in + let ctx = end_loans_at_place config access p ctx in + let v = read_place_unwrap config access p ctx in + (ctx, v) + +(** Drop a value at a given place *) +let drop_value (config : C.config) (ctx : C.eval_ctx) (p : E.place) : C.eval_ctx + = + L.log#ldebug (lazy ("drop_value: place: " ^ place_to_string ctx p)); + (* Prepare the place (by ending the loans, then the borrows) *) + let ctx, v = prepare_lplace config p ctx in + (* Replace the value with [Bottom] *) + let nv = { v with value = V.Bottom } in + let ctx = write_place_unwrap config Write p nv ctx in + ctx + +(** Assign a value to a given place *) +let assign_to_place (config : C.config) (ctx : C.eval_ctx) (v : V.typed_value) + (p : E.place) : C.eval_ctx = + (* Prepare the destination *) + let ctx, _ = prepare_lplace config p ctx in + (* Update the destination *) + let ctx = write_place_unwrap config Write p v ctx in + ctx + (** Convert a constant operand value to a typed value *) let constant_value_to_typed_value (ctx : C.eval_ctx) (ty : T.ety) (cv : E.operand_constant_value) : V.typed_value = @@ -66,14 +94,6 @@ let constant_value_to_typed_value (ctx : C.eval_ctx) (ty : T.ety) | _, Unit | _, ConstantAdt _ | _, ConstantValue _ -> failwith "Improperly typed constant value" -(** Small utility *) -let prepare_rplace (config : C.config) (access : access_kind) (p : E.place) - (ctx : C.eval_ctx) : C.eval_ctx * V.typed_value = - let ctx = update_ctx_along_read_place config access p ctx in - let ctx = end_loans_at_place config access p ctx in - let v = read_place_unwrap config access p ctx in - (ctx, v) - (** Prepare the evaluation of an operand. *) let eval_operand_prepare (config : C.config) (ctx : C.eval_ctx) (op : E.operand) : C.eval_ctx * V.typed_value = @@ -454,23 +474,3 @@ let eval_rvalue (config : C.config) (ctx : C.eval_ctx) (rvalue : E.rvalue) : match eval_rvalue_non_discriminant config ctx rvalue with | Error e -> Error e | Ok res -> Ok [ res ]) - -(** Drop a value at a given place *) -let drop_value (config : C.config) (ctx : C.eval_ctx) (p : E.place) : C.eval_ctx - = - L.log#ldebug (lazy ("drop_value: place: " ^ place_to_string ctx p)); - (* Prepare the place (by ending the loans, then the borrows) *) - let ctx, v = prepare_lplace config p ctx in - (* Replace the value with [Bottom] *) - let nv = { v with value = V.Bottom } in - let ctx = write_place_unwrap config Write p nv ctx in - ctx - -(** Assign a value to a given place *) -let assign_to_place (config : C.config) (ctx : C.eval_ctx) (v : V.typed_value) - (p : E.place) : C.eval_ctx = - (* Prepare the destination *) - let ctx, _ = prepare_lplace config p ctx in - (* Update the destination *) - let ctx = write_place_unwrap config Write p v ctx in - ctx -- cgit v1.2.3 From ea2d6637cfd9f6e17d1b411fb03e9f6c50edc331 Mon Sep 17 00:00:00 2001 From: Son Ho Date: Thu, 6 Jan 2022 10:41:24 +0100 Subject: Move some definitions from Interpreter to InterpreterStatements --- src/Interpreter.ml | 895 +------------------------------------------ src/InterpreterStatements.ml | 894 ++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 895 insertions(+), 894 deletions(-) create mode 100644 src/InterpreterStatements.ml (limited to 'src') diff --git a/src/Interpreter.ml b/src/Interpreter.ml index 73967f61..f3e94dbe 100644 --- a/src/Interpreter.ml +++ b/src/Interpreter.ml @@ -18,6 +18,7 @@ open InterpreterBorrows open InterpreterExpansion open InterpreterPaths open InterpreterExpressions +open InterpreterStatements (* TODO: check that the value types are correct when evaluating *) (* TODO: for debugging purposes, we might want to put use eval_ctx everywhere @@ -34,900 +35,6 @@ open InterpreterExpressions (* TODO: remove the config parameters when they are useless *) -(** Result of evaluating a statement *) -type statement_eval_res = Unit | Break of int | Continue of int | Return - -(** Updates the discriminant of a value at a given place. - - There are two situations: - - either the discriminant is already the proper one (in which case we - don't do anything) - - or it is not the proper one (because the variant is not the proper - one, or the value is actually [Bottom] - this happens when - initializing ADT values), in which case we replace the value with - a variant with all its fields set to [Bottom]. - For instance, something like: `Cons Bottom Bottom`. - *) -let set_discriminant (config : C.config) (ctx : C.eval_ctx) (p : E.place) - (variant_id : T.VariantId.id) : C.eval_ctx * statement_eval_res = - (* Access the value *) - let access = Write in - let ctx = update_ctx_along_read_place config access p ctx in - let ctx = end_loan_exactly_at_place config access p ctx in - let v = read_place_unwrap config access p ctx in - (* Update the value *) - match (v.V.ty, v.V.value) with - | T.Adt (T.AdtId def_id, regions, types), V.Adt av -> ( - (* There are two situations: - - either the discriminant is already the proper one (in which case we - don't do anything) - - or it is not the proper one, in which case we replace the value with - a variant with all its fields set to [Bottom] - *) - match av.variant_id with - | None -> failwith "Found a struct value while expected an enum" - | Some variant_id' -> - if variant_id' = variant_id then (* Nothing to do *) - (ctx, Unit) - else - (* Replace the value *) - let bottom_v = - compute_expanded_bottom_adt_value ctx.type_context.type_defs - def_id (Some variant_id) regions types - in - let ctx = write_place_unwrap config access p bottom_v ctx in - (ctx, Unit)) - | T.Adt (T.AdtId def_id, regions, types), V.Bottom -> - let bottom_v = - compute_expanded_bottom_adt_value ctx.type_context.type_defs def_id - (Some variant_id) regions types - in - let ctx = write_place_unwrap config access p bottom_v ctx in - (ctx, Unit) - | _, V.Symbolic _ -> - assert (config.mode = SymbolicMode); - (* This is a bit annoying: in theory we should expand the symbolic value - * then set the discriminant, because in the case the discriminant is - * exactly the one we set, the fields are left untouched, and in the - * other cases they are set to Bottom. - * For now, we forbid setting the discriminant of a symbolic value: - * setting a discriminant should only be used to initialize a value, - * really. *) - failwith "Unexpected value" - | _, (V.Adt _ | V.Bottom) -> failwith "Inconsistent state" - | _, (V.Concrete _ | V.Borrow _ | V.Loan _) -> failwith "Unexpected value" - -(** Push a frame delimiter in the context's environment *) -let ctx_push_frame (ctx : C.eval_ctx) : C.eval_ctx = - { ctx with env = Frame :: ctx.env } - -(** Drop a value at a given place *) -let drop_value (config : C.config) (ctx : C.eval_ctx) (p : E.place) : C.eval_ctx - = - L.log#ldebug (lazy ("drop_value: place: " ^ place_to_string ctx p)); - (* Prepare the place (by ending the loans, then the borrows) *) - let ctx, v = prepare_lplace config p ctx in - (* Replace the value with [Bottom] *) - let nv = { v with value = V.Bottom } in - let ctx = write_place_unwrap config Write p nv ctx in - ctx - -(** Small helper: compute the type of the return value for a specific - instantiation of a non-local function. - *) -let get_non_local_function_return_type (fid : A.assumed_fun_id) - (region_params : T.erased_region list) (type_params : T.ety list) : T.ety = - match (fid, region_params, type_params) with - | A.BoxNew, [], [ bty ] -> T.Adt (T.Assumed T.Box, [], [ bty ]) - | A.BoxDeref, [], [ bty ] -> T.Ref (T.Erased, bty, T.Shared) - | A.BoxDerefMut, [], [ bty ] -> T.Ref (T.Erased, bty, T.Mut) - | A.BoxFree, [], [ _ ] -> mk_unit_ty - | _ -> failwith "Inconsistent state" - -(** Pop the current frame. - - Drop all the local variables but the return variable, move the return - value out of the return variable, remove all the local variables (but not the - abstractions!) from the context, remove the [Frame] indicator delimiting the - current frame and return the return value and the updated context. - *) -let ctx_pop_frame (config : C.config) (ctx : C.eval_ctx) : - C.eval_ctx * V.typed_value = - (* Debug *) - L.log#ldebug (lazy ("ctx_pop_frame:\n" ^ eval_ctx_to_string ctx)); - (* Eval *) - let ret_vid = V.VarId.zero in - (* List the local variables, but the return variable *) - let rec list_locals env = - match env with - | [] -> failwith "Inconsistent environment" - | C.Abs _ :: env -> list_locals env - | C.Var (var, _) :: env -> - let locals = list_locals env in - if var.index <> ret_vid then var.index :: locals else locals - | C.Frame :: _ -> [] - in - let locals = list_locals ctx.env in - (* Debug *) - L.log#ldebug - (lazy - ("ctx_pop_frame: locals to drop: [" - ^ String.concat "," (List.map V.VarId.to_string locals) - ^ "]")); - (* Drop the local variables *) - let ctx = - List.fold_left - (fun ctx lid -> drop_value config ctx (mk_place_from_var_id lid)) - ctx locals - in - (* Debug *) - L.log#ldebug - (lazy - ("ctx_pop_frame: after dropping local variables:\n" - ^ eval_ctx_to_string ctx)); - (* Move the return value out of the return variable *) - let ctx, ret_value = - eval_operand config ctx (E.Move (mk_place_from_var_id ret_vid)) - in - (* Pop the frame *) - let rec pop env = - match env with - | [] -> failwith "Inconsistent environment" - | C.Abs abs :: env -> C.Abs abs :: pop env - | C.Var (_, _) :: env -> pop env - | C.Frame :: env -> env - in - let env = pop ctx.env in - let ctx = { ctx with env } in - (ctx, ret_value) - -(** Assign a value to a given place *) -let assign_to_place (config : C.config) (ctx : C.eval_ctx) (v : V.typed_value) - (p : E.place) : C.eval_ctx = - (* Prepare the destination *) - let ctx, _ = prepare_lplace config p ctx in - (* Update the destination *) - let ctx = write_place_unwrap config Write p v ctx in - ctx - -(** Auxiliary function - see [eval_non_local_function_call] *) -let eval_box_new_concrete (config : C.config) - (region_params : T.erased_region list) (type_params : T.ety list) - (ctx : C.eval_ctx) : C.eval_ctx eval_result = - (* Check and retrieve the arguments *) - match (region_params, type_params, ctx.env) with - | ( [], - [ boxed_ty ], - Var (input_var, input_value) :: Var (_ret_var, _) :: C.Frame :: _ ) -> - (* Required type checking *) - assert (input_value.V.ty = boxed_ty); - - (* Move the input value *) - let ctx, moved_input_value = - eval_operand config ctx - (E.Move (mk_place_from_var_id input_var.C.index)) - in - - (* Create the box value *) - let box_ty = T.Adt (T.Assumed T.Box, [], [ boxed_ty ]) in - let box_v = - V.Adt { variant_id = None; field_values = [ moved_input_value ] } - in - let box_v = mk_typed_value box_ty box_v in - - (* Move this value to the return variable *) - let dest = mk_place_from_var_id V.VarId.zero in - let ctx = assign_to_place config ctx box_v dest in - - (* Return *) - Ok ctx - | _ -> failwith "Inconsistent state" - -(** Auxiliary function which factorizes code to evaluate `std::Deref::deref` - and `std::DerefMut::deref_mut` - see [eval_non_local_function_call] *) -let eval_box_deref_mut_or_shared_concrete (config : C.config) - (region_params : T.erased_region list) (type_params : T.ety list) - (is_mut : bool) (ctx : C.eval_ctx) : C.eval_ctx eval_result = - (* Check the arguments *) - match (region_params, type_params, ctx.env) with - | ( [], - [ boxed_ty ], - Var (input_var, input_value) :: Var (_ret_var, _) :: C.Frame :: _ ) -> ( - (* Required type checking. We must have: - - input_value.ty == & (mut) Box - - boxed_ty == ty - for some ty - *) - (let _, input_ty, ref_kind = ty_get_ref input_value.V.ty in - assert (match ref_kind with T.Shared -> not is_mut | T.Mut -> is_mut); - let input_ty = ty_get_box input_ty in - assert (input_ty = boxed_ty)); - - (* Borrow the boxed value *) - let p = - { E.var_id = input_var.C.index; projection = [ E.Deref; E.DerefBox ] } - in - let borrow_kind = if is_mut then E.Mut else E.Shared in - let rv = E.Ref (p, borrow_kind) in - (* Note that the rvalue can't be a discriminant value *) - match eval_rvalue_non_discriminant config ctx rv with - | Error err -> Error err - | Ok (ctx, borrowed_value) -> - (* Move the borrowed value to its destination *) - let destp = mk_place_from_var_id V.VarId.zero in - let ctx = assign_to_place config ctx borrowed_value destp in - Ok ctx) - | _ -> failwith "Inconsistent state" - -(** Auxiliary function - see [eval_non_local_function_call] *) -let eval_box_deref_concrete (config : C.config) - (region_params : T.erased_region list) (type_params : T.ety list) - (ctx : C.eval_ctx) : C.eval_ctx eval_result = - let is_mut = false in - eval_box_deref_mut_or_shared_concrete config region_params type_params is_mut - ctx - -(** Auxiliary function - see [eval_non_local_function_call] *) -let eval_box_deref_mut_concrete (config : C.config) - (region_params : T.erased_region list) (type_params : T.ety list) - (ctx : C.eval_ctx) : C.eval_ctx eval_result = - let is_mut = true in - eval_box_deref_mut_or_shared_concrete config region_params type_params is_mut - ctx - -(** Auxiliary function - see [eval_non_local_function_call]. - - `Box::free` is not handled the same way as the other assumed functions: - - in the regular case, whenever we need to evaluate an assumed function, - we evaluate the operands, push a frame, call a dedicated function - to correctly update the variables in the frame (and mimic the execution - of a body) and finally pop the frame - - in the case of `Box::free`: the value given to this function is often - of the form `Box(⊥)` because we can move the value out of the - box before freeing the box. It makes it invalid to see box_free as a - "regular" function: it is not valid to call a function with arguments - which contain `⊥`. For this reason, we execute `Box::free` as drop_value, - but this is a bit annoying with regards to the semantics... - - Followingly this function doesn't behave like the others: it does not expect - a stack frame to have been pushed, but rather simply behaves like [drop_value]. - It thus updates the box value (by calling [drop_value]) and updates - the destination (by setting it to `()`). -*) -let eval_box_free (config : C.config) (region_params : T.erased_region list) - (type_params : T.ety list) (args : E.operand list) (dest : E.place) - (ctx : C.eval_ctx) : C.eval_ctx = - match (region_params, type_params, args) with - | [], [ boxed_ty ], [ E.Move input_box_place ] -> - (* Required type checking *) - let input_box = read_place_unwrap config Write input_box_place ctx in - (let input_ty = ty_get_box input_box.V.ty in - assert (input_ty = boxed_ty)); - - (* Drop the value *) - let ctx = drop_value config ctx input_box_place in - - (* Update the destination by setting it to `()` *) - let ctx = assign_to_place config ctx mk_unit_value dest in - - (* Return *) - ctx - | _ -> failwith "Inconsistent state" - -(** Auxiliary function - see [eval_non_local_function_call] *) -let eval_box_new_inst_sig (region_params : T.erased_region list) - (type_params : T.ety list) : A.inst_fun_sig = - (* The signature is: - `T -> Box` - where T is the type pram - *) - match (region_params, type_params) with - | [], [ ty_param ] -> - let input = ety_no_regions_to_rty ty_param in - let output = mk_box_ty ty_param in - let output = ety_no_regions_to_rty output in - { A.regions_hierarchy = []; inputs = [ input ]; output } - | _ -> failwith "Inconsistent state" - -(** Auxiliary function which factorizes code to evaluate `std::Deref::deref` - and `std::DerefMut::deref_mut` - see [eval_non_local_function_call] *) -let eval_box_deref_mut_or_shared_inst_sig (region_params : T.erased_region list) - (type_params : T.ety list) (is_mut : bool) (ctx : C.eval_ctx) : - C.eval_ctx * A.inst_fun_sig = - (* The signature is: - `&'a (mut) Box -> &'a (mut) T` - where T is the type param - *) - let ctx, rid = C.fresh_region_id ctx in - let r = T.Var rid in - let ctx, abs_id = C.fresh_abstraction_id ctx in - match (region_params, type_params) with - | [], [ ty_param ] -> - let ty_param = ety_no_regions_to_rty ty_param in - let ref_kind = if is_mut then T.Mut else T.Shared in - - let input = mk_box_ty ty_param in - let input = mk_ref_ty r input ref_kind in - - let output = mk_ref_ty r ty_param ref_kind in - - let regions = { A.id = abs_id; regions = [ rid ]; parents = [] } in - - let inst_sg = - { A.regions_hierarchy = [ regions ]; inputs = [ input ]; output } - in - - (ctx, inst_sg) - | _ -> failwith "Inconsistent state" - -(** Auxiliary function - see [eval_non_local_function_call] *) -let eval_box_deref_inst_sig (region_params : T.erased_region list) - (type_params : T.ety list) (ctx : C.eval_ctx) : C.eval_ctx * A.inst_fun_sig - = - let is_mut = false in - eval_box_deref_mut_or_shared_inst_sig region_params type_params is_mut ctx - -(** Auxiliary function - see [eval_non_local_function_call] *) -let eval_box_deref_mut_inst_sig (region_params : T.erased_region list) - (type_params : T.ety list) (ctx : C.eval_ctx) : C.eval_ctx * A.inst_fun_sig - = - let is_mut = true in - eval_box_deref_mut_or_shared_inst_sig region_params type_params is_mut ctx - -(** Evaluate a non-local function call in concrete mode *) -let eval_non_local_function_call_concrete (config : C.config) (ctx : C.eval_ctx) - (fid : A.assumed_fun_id) (region_params : T.erased_region list) - (type_params : T.ety list) (args : E.operand list) (dest : E.place) : - C.eval_ctx eval_result = - (* There are two cases (and this is extremely annoying): - - the function is not box_free - - the function is box_free - See [eval_box_free] - *) - match fid with - | A.BoxFree -> - (* Degenerate case: box_free *) - Ok (eval_box_free config region_params type_params args dest ctx) - | _ -> ( - (* "Normal" case: not box_free *) - (* Evaluate the operands *) - let ctx, args_vl = eval_operands config ctx args in - - (* Push the stack frame: we initialize the frame with the return variable, - and one variable per input argument *) - let ctx = ctx_push_frame ctx in - - (* Create and push the return variable *) - let ret_vid = V.VarId.zero in - let ret_ty = - get_non_local_function_return_type fid region_params type_params - in - let ret_var = mk_var ret_vid (Some "@return") ret_ty in - let ctx = C.ctx_push_uninitialized_var ctx ret_var in - - (* Create and push the input variables *) - let input_vars = - V.VarId.mapi_from1 - (fun id (v : V.typed_value) -> (mk_var id None v.V.ty, v)) - args_vl - in - let ctx = C.ctx_push_vars ctx input_vars in - - (* "Execute" the function body. As the functions are assumed, here we call - custom functions to perform the proper manipulations: we don't have - access to a body. *) - let res = - match fid with - | A.BoxNew -> eval_box_new_concrete config region_params type_params ctx - | A.BoxDeref -> - eval_box_deref_concrete config region_params type_params ctx - | A.BoxDerefMut -> - eval_box_deref_mut_concrete config region_params type_params ctx - | A.BoxFree -> failwith "Unreachable" - (* should have been treated above *) - in - - (* Check if the function body evaluated correctly *) - match res with - | Error err -> Error err - | Ok ctx -> - (* Pop the stack frame and retrieve the return value *) - let ctx, ret_value = ctx_pop_frame config ctx in - - (* Move the return value to its destination *) - let ctx = assign_to_place config ctx ret_value dest in - - (* Return *) - Ok ctx) - -(** Evaluate a statement *) -let rec eval_statement (config : C.config) (ctx : C.eval_ctx) (st : A.statement) - : (C.eval_ctx * statement_eval_res) eval_result list = - (* Debugging *) - L.log#ldebug - (lazy - ("\n" ^ eval_ctx_to_string ctx ^ "\nAbout to evaluate statement: " - ^ statement_to_string ctx st ^ "\n")); - (* Sanity check *) - if config.C.check_invariants then Inv.check_invariants ctx; - (* Evaluate *) - match st with - | A.Assign (p, rvalue) -> ( - (* Evaluate the rvalue *) - match eval_rvalue config ctx rvalue with - | Error err -> [ Error err ] - | Ok res -> - (* Assign *) - let assign (ctx, rvalue) = - let ctx = assign_to_place config ctx rvalue p in - Ok (ctx, Unit) - in - List.map assign res) - | A.FakeRead p -> - let ctx, _ = prepare_rplace config Read p ctx in - [ Ok (ctx, Unit) ] - | A.SetDiscriminant (p, variant_id) -> - [ Ok (set_discriminant config ctx p variant_id) ] - | A.Drop p -> [ Ok (drop_value config ctx p, Unit) ] - | A.Assert assertion -> ( - let ctx, v = eval_operand config ctx assertion.cond in - assert (v.ty = T.Bool); - match v.value with - | Concrete (Bool b) -> - if b = assertion.expected then [ Ok (ctx, Unit) ] else [ Error Panic ] - | _ -> failwith "Expected a boolean") - | A.Call call -> eval_function_call config ctx call - | A.Panic -> [ Error Panic ] - | A.Return -> [ Ok (ctx, Return) ] - | A.Break i -> [ Ok (ctx, Break i) ] - | A.Continue i -> [ Ok (ctx, Continue i) ] - | A.Nop -> [ Ok (ctx, Unit) ] - | A.Sequence (st1, st2) -> - (* Evaluate the first statement *) - let res1 = eval_statement config ctx st1 in - (* Evaluate the sequence *) - let eval_seq res1 = - match res1 with - | Error err -> [ Error err ] - | Ok (ctx, Unit) -> - (* Evaluate the second statement *) - eval_statement config ctx st2 - (* Control-flow break: transmit. We enumerate the cases on purpose *) - | Ok (ctx, Break i) -> [ Ok (ctx, Break i) ] - | Ok (ctx, Continue i) -> [ Ok (ctx, Continue i) ] - | Ok (ctx, Return) -> [ Ok (ctx, Return) ] - in - List.concat (List.map eval_seq res1) - | A.Loop loop_body -> - (* For now, we don't support loops in symbolic mode *) - assert (config.C.mode = C.ConcreteMode); - (* Evaluate a loop body - - We need a specific function for the [Continue] case: in case we continue, - we might have to reevaluate the current loop body with the new context - (and repeat this an indefinite number of times). - *) - let rec eval_loop_body (ctx : C.eval_ctx) : - (C.eval_ctx * statement_eval_res) eval_result list = - (* Evaluate the loop body *) - let body_res = eval_statement config ctx loop_body in - (* Evaluate the next steps *) - let eval res = - match res with - | Error err -> [ Error err ] - | Ok (ctx, Unit) -> - (* We finished evaluating the statement in a "normal" manner *) - [ Ok (ctx, Unit) ] - (* Control-flow breaks *) - | Ok (ctx, Break i) -> - (* Decrease the break index *) - if i = 0 then [ Ok (ctx, Unit) ] else [ Ok (ctx, Break (i - 1)) ] - | Ok (ctx, Continue i) -> - (* Decrease the continue index *) - if i = 0 then - (* We stop there. When we continue, we go back to the beginning - of the loop: we must thus reevaluate the loop body (and - recheck the result to know whether we must reevaluate again, - etc. *) - eval_loop_body ctx - else - (* We don't stop there: transmit *) - [ Ok (ctx, Continue (i - 1)) ] - | Ok (ctx, Return) -> [ Ok (ctx, Return) ] - in - List.concat (List.map eval body_res) - in - (* Apply *) - eval_loop_body ctx - | A.Switch (op, tgts) -> eval_switch config op tgts ctx - -(** Evaluate a switch *) -and eval_switch (config : C.config) (op : E.operand) (tgts : A.switch_targets) - (ctx : C.eval_ctx) : (C.eval_ctx * statement_eval_res) eval_result list = - (* We evaluate the operand in two steps: - * first we prepare it, then we check if its value is concrete or - * symbolic. If it is concrete, we can then evaluate the operand - * directly, otherwise we must first expand the value. - * Note that we can't fully evaluate the operand *then* expand the - * value if it is symbolic, because the value may have been move - * (and would thus floating in thin air...)! - * *) - (* Prepare the operand *) - let ctx, op_v = eval_operand_prepare config ctx op in - (* Match on the targets *) - match tgts with - | A.If (st1, st2) -> ( - match op_v.value with - | V.Concrete (V.Bool b) -> - (* Evaluate the operand *) - let ctx, op_v' = eval_operand config ctx op in - assert (op_v' = op_v); - (* Branch *) - if b then eval_statement config ctx st1 - else eval_statement config ctx st2 - | V.Symbolic sv -> - (* Synthesis *) - S.synthesize_symbolic_expansion_if_branching sv.V.svalue; - (* Expand the symbolic value to true or false *) - let see_true = SeConcrete (V.Bool true) in - let see_false = SeConcrete (V.Bool false) in - let expand_and_execute see st = - (* Apply the symbolic expansion *) - let ctx = - apply_symbolic_expansion_non_borrow config sv.V.svalue see ctx - in - (* Evaluate the operand *) - let ctx, _ = eval_operand config ctx op in - (* Evaluate the branch *) - eval_statement config ctx st - in - (* Execute the two branches *) - List.append - (expand_and_execute see_true st1) - (expand_and_execute see_false st2) - | _ -> failwith "Inconsistent state") - | A.SwitchInt (int_ty, tgts, otherwise) -> ( - match op_v.value with - | V.Concrete (V.Scalar sv) -> ( - (* Evaluate the operand *) - let ctx, op_v' = eval_operand config ctx op in - assert (op_v' = op_v); - (* Sanity check *) - assert (sv.V.int_ty = int_ty); - (* Find the branch *) - match List.find_opt (fun (sv', _) -> sv = sv') tgts with - | None -> eval_statement config ctx otherwise - | Some (_, tgt) -> eval_statement config ctx tgt) - | V.Symbolic sv -> - (* Synthesis *) - S.synthesize_symbolic_expansion_switch_int_branching sv.V.svalue; - (* For all the branches of the switch, we expand the symbolic value - * to the value given by the branch and execute the branch statement. - * For the otherwise branch, we leave the symbolic value as it is - * (because this branch doesn't precisely define which should be the - * value of the scrutinee...) and simply execute the otherwise statement. - *) - (* Branches other than "otherwise" *) - let exec_branch (switch_value, branch_st) = - let see = SeConcrete (V.Scalar switch_value) in - (* Apply the symbolic expansion *) - let ctx = - apply_symbolic_expansion_non_borrow config sv.V.svalue see ctx - in - (* Evaluate the operand *) - let ctx, _ = eval_operand config ctx op in - (* Evaluate the branch *) - eval_statement config ctx branch_st - in - let ctxl = List.map exec_branch tgts in - (* Otherwise branch *) - let ctx_otherwise = eval_statement config ctx otherwise in - (* Put everything together *) - List.append (List.concat ctxl) ctx_otherwise - | _ -> failwith "Inconsistent state") - -(** Evaluate a function call (auxiliary helper for [eval_statement]) *) -and eval_function_call (config : C.config) (ctx : C.eval_ctx) (call : A.call) : - (C.eval_ctx * statement_eval_res) eval_result list = - (* There are two cases * - - this is a local function, in which case we execute its body - - this is a non-local function, in which case there is a special treatment - *) - let res = - match call.func with - | A.Local fid -> - eval_local_function_call config ctx fid call.region_params - call.type_params call.args call.dest - | A.Assumed fid -> - [ - eval_non_local_function_call config ctx fid call.region_params - call.type_params call.args call.dest; - ] - in - List.map - (fun res -> - match res with Error err -> Error err | Ok ctx -> Ok (ctx, Unit)) - res - -(** Evaluate a local (i.e., non-assumed) function call in concrete mode *) -and eval_local_function_call_concrete (config : C.config) (ctx : C.eval_ctx) - (fid : A.FunDefId.id) (_region_params : T.erased_region list) - (type_params : T.ety list) (args : E.operand list) (dest : E.place) : - C.eval_ctx eval_result list = - (* Retrieve the (correctly instantiated) body *) - let def = C.ctx_lookup_fun_def ctx fid in - let tsubst = - Subst.make_type_subst - (List.map (fun v -> v.T.index) def.A.signature.type_params) - type_params - in - let locals, body = Subst.fun_def_substitute_in_body tsubst def in - - (* Evaluate the input operands *) - let ctx, args = eval_operands config ctx args in - assert (List.length args = def.A.arg_count); - - (* Push a frame delimiter *) - let ctx = ctx_push_frame ctx in - - (* Compute the initial values for the local variables *) - (* 1. Push the return value *) - let ret_var, locals = - match locals with - | ret_ty :: locals -> (ret_ty, locals) - | _ -> failwith "Unreachable" - in - let ctx = C.ctx_push_var ctx ret_var (C.mk_bottom ret_var.var_ty) in - - (* 2. Push the input values *) - let input_locals, locals = Utilities.list_split_at locals def.A.arg_count in - let inputs = List.combine input_locals args in - (* Note that this function checks that the variables and their values - have the same type (this is important) *) - let ctx = C.ctx_push_vars ctx inputs in - - (* 3. Push the remaining local variables (initialized as [Bottom]) *) - let ctx = C.ctx_push_uninitialized_vars ctx locals in - - (* Execute the function body *) - let res = eval_function_body config ctx body in - - (* Pop the stack frame and move the return value to its destination *) - let finish res = - match res with - | Error Panic -> Error Panic - | Ok ctx -> - (* Pop the stack frame and retrieve the return value *) - let ctx, ret_value = ctx_pop_frame config ctx in - - (* Move the return value to its destination *) - let ctx = assign_to_place config ctx ret_value dest in - - (* Return *) - Ok ctx - in - List.map finish res - -(** Evaluate a local (i.e., non-assumed) function call in symbolic mode *) -and eval_local_function_call_symbolic (config : C.config) (ctx : C.eval_ctx) - (fid : A.FunDefId.id) (region_params : T.erased_region list) - (type_params : T.ety list) (args : E.operand list) (dest : E.place) : - C.eval_ctx = - (* Retrieve the (correctly instantiated) signature *) - let def = C.ctx_lookup_fun_def ctx fid in - let sg = def.A.signature in - (* Generate fresh abstraction ids and create a substitution from region - * group ids to abstraction ids *) - let ctx, rg_abs_ids_bindings = - List.fold_left_map - (fun ctx rg -> - let ctx, abs_id = C.fresh_abstraction_id ctx in - (ctx, (rg.A.id, abs_id))) - ctx sg.regions_hierarchy - in - let asubst_map : V.AbstractionId.id A.RegionGroupId.Map.t = - List.fold_left - (fun mp (rg_id, abs_id) -> A.RegionGroupId.Map.add rg_id abs_id mp) - A.RegionGroupId.Map.empty rg_abs_ids_bindings - in - let asubst (rg_id : A.RegionGroupId.id) : V.AbstractionId.id = - A.RegionGroupId.Map.find rg_id asubst_map - in - (* Generate fresh regions and their substitutions *) - let ctx, _, rsubst, _ = - Subst.fresh_regions_with_substs sg.region_params ctx - in - (* Generate the type substitution - * Note that we need the substitution to map the type variables to - * [rty] types (not [ety]). In order to do that, we convert the - * type parameters to types with regions. This is possible only - * if those types don't contain any regions. - * This is a current limitation of the analysis: there is still some - * work to do to properly handle full type parametrization. - * *) - let rtype_params = List.map ety_no_regions_to_rty type_params in - let tsubst = - Subst.make_type_subst - (List.map (fun v -> v.T.index) sg.type_params) - rtype_params - in - (* Substitute the signature *) - let inst_sg = Subst.substitute_signature asubst rsubst tsubst sg in - (* Sanity check *) - assert (List.length args = def.A.arg_count); - (* Evaluate the function call *) - eval_function_call_symbolic_from_inst_sig config ctx (A.Local fid) inst_sg - region_params type_params args dest - -(** Evaluate a function call in symbolic mode by using the function signature. - - This allows us to factorize the evaluation of local and non-local function - calls in symbolic mode: only their signatures matter. - *) -and eval_function_call_symbolic_from_inst_sig (config : C.config) - (ctx : C.eval_ctx) (fid : A.fun_id) (inst_sg : A.inst_fun_sig) - (region_params : T.erased_region list) (type_params : T.ety list) - (args : E.operand list) (dest : E.place) : C.eval_ctx = - (* Generate a fresh symbolic value for the return value *) - let ret_sv_ty = inst_sg.A.output in - let ctx, ret_spc = - mk_fresh_symbolic_proj_comp T.RegionId.Set.empty ret_sv_ty ctx - in - let ret_value = mk_typed_value_from_proj_comp ret_spc in - let ret_av = V.ASymbolic (V.AProjLoans ret_spc.V.svalue) in - let ret_av : V.typed_avalue = - { V.value = ret_av; V.ty = ret_spc.V.svalue.V.sv_ty } - in - (* Evaluate the input operands *) - let ctx, args = eval_operands config ctx args in - let args_with_rtypes = List.combine args inst_sg.A.inputs in - (* Check the type of the input arguments *) - assert ( - List.for_all - (fun ((arg, rty) : V.typed_value * T.rty) -> - arg.V.ty = Subst.erase_regions rty) - args_with_rtypes); - (* Generate the abstractions from the region groups and add them to the context *) - let gen_abs (ctx : C.eval_ctx) (rg : A.abs_region_group) : C.eval_ctx = - let abs_id = rg.A.id in - let parents = - List.fold_left - (fun s pid -> V.AbstractionId.Set.add pid s) - V.AbstractionId.Set.empty rg.A.parents - in - let regions = - List.fold_left - (fun s rid -> T.RegionId.Set.add rid s) - T.RegionId.Set.empty rg.A.regions - in - (* Project over the input values *) - let ctx, args_projs = - List.fold_left_map - (fun ctx (arg, arg_rty) -> - apply_proj_borrows_on_input_value config ctx regions arg arg_rty) - ctx args_with_rtypes - in - (* Group the input and output values *) - let avalues = List.append args_projs [ ret_av ] in - (* Create the abstraction *) - let abs = { V.abs_id; parents; regions; avalues } in - (* Insert the abstraction in the context *) - let ctx = { ctx with env = Abs abs :: ctx.env } in - (* Return *) - ctx - in - let ctx = List.fold_left gen_abs ctx inst_sg.A.regions_hierarchy in - (* Move the return value to its destination *) - let ctx = assign_to_place config ctx ret_value dest in - (* Synthesis *) - S.synthesize_function_call fid region_params type_params args dest - ret_spc.V.svalue; - (* Return *) - ctx - -(** Evaluate a non-local function call in symbolic mode *) -and eval_non_local_function_call_symbolic (config : C.config) (ctx : C.eval_ctx) - (fid : A.assumed_fun_id) (region_params : T.erased_region list) - (type_params : T.ety list) (args : E.operand list) (dest : E.place) : - C.eval_ctx = - (* Sanity check: make sure the type parameters don't contain regions - - * this is a current limitation of our synthesis *) - assert (List.for_all (fun ty -> not (ty_has_regions ty)) type_params); - - (* There are two cases (and this is extremely annoying): - - the function is not box_free - - the function is box_free - See [eval_box_free] - *) - match fid with - | A.BoxFree -> - (* Degenerate case: box_free - note that this is not really a function - * call: no need to call a "synthesize_..." function *) - eval_box_free config region_params type_params args dest ctx - | _ -> - (* "Normal" case: not box_free *) - (* In symbolic mode, the behaviour of a function call is completely defined - * by the signature of the function: we thus simply generate correctly - * instantiated signatures, and delegate the work to an auxiliary function *) - let ctx, inst_sig = - match fid with - | A.BoxNew -> (ctx, eval_box_new_inst_sig region_params type_params) - | A.BoxDeref -> eval_box_deref_inst_sig region_params type_params ctx - | A.BoxDerefMut -> - eval_box_deref_mut_inst_sig region_params type_params ctx - | A.BoxFree -> failwith "Unreachable" - (* should have been treated above *) - in - - (* Evaluate the function call *) - eval_function_call_symbolic_from_inst_sig config ctx (A.Assumed fid) - inst_sig region_params type_params args dest - -(** Evaluate a non-local (i.e, assumed) function call such as `Box::deref` - (auxiliary helper for [eval_statement]) *) -and eval_non_local_function_call (config : C.config) (ctx : C.eval_ctx) - (fid : A.assumed_fun_id) (region_params : T.erased_region list) - (type_params : T.ety list) (args : E.operand list) (dest : E.place) : - C.eval_ctx eval_result = - (* Debug *) - L.log#ldebug - (lazy - (let type_params = - "[" - ^ String.concat ", " (List.map (ety_to_string ctx) type_params) - ^ "]" - in - let args = - "[" ^ String.concat ", " (List.map (operand_to_string ctx) args) ^ "]" - in - let dest = place_to_string ctx dest in - "eval_non_local_function_call:\n- fid:" ^ A.show_assumed_fun_id fid - ^ "\n- type_params: " ^ type_params ^ "\n- args: " ^ args ^ "\n- dest: " - ^ dest)); - - match config.mode with - | C.ConcreteMode -> - eval_non_local_function_call_concrete config ctx fid region_params - type_params args dest - | C.SymbolicMode -> - Ok - (eval_non_local_function_call_symbolic config ctx fid region_params - type_params args dest) - -(** Evaluate a local (i.e, not assumed) function call (auxiliary helper for - [eval_statement]) *) -and eval_local_function_call (config : C.config) (ctx : C.eval_ctx) - (fid : A.FunDefId.id) (region_params : T.erased_region list) - (type_params : T.ety list) (args : E.operand list) (dest : E.place) : - C.eval_ctx eval_result list = - match config.mode with - | ConcreteMode -> - eval_local_function_call_concrete config ctx fid region_params type_params - args dest - | SymbolicMode -> - [ - Ok - (eval_local_function_call_symbolic config ctx fid region_params - type_params args dest); - ] - -(** Evaluate a statement seen as a function body (auxiliary helper for - [eval_statement]) *) -and eval_function_body (config : C.config) (ctx : C.eval_ctx) - (body : A.statement) : (C.eval_ctx, eval_error) result list = - let res = eval_statement config ctx body in - let finish res = - match res with - | Error err -> Error err - | Ok (ctx, res) -> ( - (* Sanity check *) - if config.C.check_invariants then Inv.check_invariants ctx; - match res with - | Unit | Break _ | Continue _ -> failwith "Inconsistent state" - | Return -> Ok ctx) - in - List.map finish res - module Test = struct (** Test a unit function (taking no arguments) by evaluating it in an empty environment diff --git a/src/InterpreterStatements.ml b/src/InterpreterStatements.ml new file mode 100644 index 00000000..ec61b5e0 --- /dev/null +++ b/src/InterpreterStatements.ml @@ -0,0 +1,894 @@ +module T = Types +module V = Values +open Scalars +module E = Expressions +open Errors +module C = Contexts +module Subst = Substitute +module A = CfimAst +module L = Logging +open TypesUtils +open ValuesUtils +module Inv = Invariants +module S = Synthesis +open Utils +open InterpreterUtils +open InterpreterProjectors +open InterpreterBorrows +open InterpreterExpansion +open InterpreterPaths +open InterpreterExpressions + +(** Result of evaluating a statement *) +type statement_eval_res = Unit | Break of int | Continue of int | Return + +(** Updates the discriminant of a value at a given place. + + There are two situations: + - either the discriminant is already the proper one (in which case we + don't do anything) + - or it is not the proper one (because the variant is not the proper + one, or the value is actually [Bottom] - this happens when + initializing ADT values), in which case we replace the value with + a variant with all its fields set to [Bottom]. + For instance, something like: `Cons Bottom Bottom`. + *) +let set_discriminant (config : C.config) (ctx : C.eval_ctx) (p : E.place) + (variant_id : T.VariantId.id) : C.eval_ctx * statement_eval_res = + (* Access the value *) + let access = Write in + let ctx = update_ctx_along_read_place config access p ctx in + let ctx = end_loan_exactly_at_place config access p ctx in + let v = read_place_unwrap config access p ctx in + (* Update the value *) + match (v.V.ty, v.V.value) with + | T.Adt (T.AdtId def_id, regions, types), V.Adt av -> ( + (* There are two situations: + - either the discriminant is already the proper one (in which case we + don't do anything) + - or it is not the proper one, in which case we replace the value with + a variant with all its fields set to [Bottom] + *) + match av.variant_id with + | None -> failwith "Found a struct value while expected an enum" + | Some variant_id' -> + if variant_id' = variant_id then (* Nothing to do *) + (ctx, Unit) + else + (* Replace the value *) + let bottom_v = + compute_expanded_bottom_adt_value ctx.type_context.type_defs + def_id (Some variant_id) regions types + in + let ctx = write_place_unwrap config access p bottom_v ctx in + (ctx, Unit)) + | T.Adt (T.AdtId def_id, regions, types), V.Bottom -> + let bottom_v = + compute_expanded_bottom_adt_value ctx.type_context.type_defs def_id + (Some variant_id) regions types + in + let ctx = write_place_unwrap config access p bottom_v ctx in + (ctx, Unit) + | _, V.Symbolic _ -> + assert (config.mode = SymbolicMode); + (* This is a bit annoying: in theory we should expand the symbolic value + * then set the discriminant, because in the case the discriminant is + * exactly the one we set, the fields are left untouched, and in the + * other cases they are set to Bottom. + * For now, we forbid setting the discriminant of a symbolic value: + * setting a discriminant should only be used to initialize a value, + * really. *) + failwith "Unexpected value" + | _, (V.Adt _ | V.Bottom) -> failwith "Inconsistent state" + | _, (V.Concrete _ | V.Borrow _ | V.Loan _) -> failwith "Unexpected value" + +(** Push a frame delimiter in the context's environment *) +let ctx_push_frame (ctx : C.eval_ctx) : C.eval_ctx = + { ctx with env = Frame :: ctx.env } + +(** Small helper: compute the type of the return value for a specific + instantiation of a non-local function. + *) +let get_non_local_function_return_type (fid : A.assumed_fun_id) + (region_params : T.erased_region list) (type_params : T.ety list) : T.ety = + match (fid, region_params, type_params) with + | A.BoxNew, [], [ bty ] -> T.Adt (T.Assumed T.Box, [], [ bty ]) + | A.BoxDeref, [], [ bty ] -> T.Ref (T.Erased, bty, T.Shared) + | A.BoxDerefMut, [], [ bty ] -> T.Ref (T.Erased, bty, T.Mut) + | A.BoxFree, [], [ _ ] -> mk_unit_ty + | _ -> failwith "Inconsistent state" + +(** Pop the current frame. + + Drop all the local variables but the return variable, move the return + value out of the return variable, remove all the local variables (but not the + abstractions!) from the context, remove the [Frame] indicator delimiting the + current frame and return the return value and the updated context. + *) +let ctx_pop_frame (config : C.config) (ctx : C.eval_ctx) : + C.eval_ctx * V.typed_value = + (* Debug *) + L.log#ldebug (lazy ("ctx_pop_frame:\n" ^ eval_ctx_to_string ctx)); + (* Eval *) + let ret_vid = V.VarId.zero in + (* List the local variables, but the return variable *) + let rec list_locals env = + match env with + | [] -> failwith "Inconsistent environment" + | C.Abs _ :: env -> list_locals env + | C.Var (var, _) :: env -> + let locals = list_locals env in + if var.index <> ret_vid then var.index :: locals else locals + | C.Frame :: _ -> [] + in + let locals = list_locals ctx.env in + (* Debug *) + L.log#ldebug + (lazy + ("ctx_pop_frame: locals to drop: [" + ^ String.concat "," (List.map V.VarId.to_string locals) + ^ "]")); + (* Drop the local variables *) + let ctx = + List.fold_left + (fun ctx lid -> drop_value config ctx (mk_place_from_var_id lid)) + ctx locals + in + (* Debug *) + L.log#ldebug + (lazy + ("ctx_pop_frame: after dropping local variables:\n" + ^ eval_ctx_to_string ctx)); + (* Move the return value out of the return variable *) + let ctx, ret_value = + eval_operand config ctx (E.Move (mk_place_from_var_id ret_vid)) + in + (* Pop the frame *) + let rec pop env = + match env with + | [] -> failwith "Inconsistent environment" + | C.Abs abs :: env -> C.Abs abs :: pop env + | C.Var (_, _) :: env -> pop env + | C.Frame :: env -> env + in + let env = pop ctx.env in + let ctx = { ctx with env } in + (ctx, ret_value) + +(** Auxiliary function - see [eval_non_local_function_call] *) +let eval_box_new_concrete (config : C.config) + (region_params : T.erased_region list) (type_params : T.ety list) + (ctx : C.eval_ctx) : C.eval_ctx eval_result = + (* Check and retrieve the arguments *) + match (region_params, type_params, ctx.env) with + | ( [], + [ boxed_ty ], + Var (input_var, input_value) :: Var (_ret_var, _) :: C.Frame :: _ ) -> + (* Required type checking *) + assert (input_value.V.ty = boxed_ty); + + (* Move the input value *) + let ctx, moved_input_value = + eval_operand config ctx + (E.Move (mk_place_from_var_id input_var.C.index)) + in + + (* Create the box value *) + let box_ty = T.Adt (T.Assumed T.Box, [], [ boxed_ty ]) in + let box_v = + V.Adt { variant_id = None; field_values = [ moved_input_value ] } + in + let box_v = mk_typed_value box_ty box_v in + + (* Move this value to the return variable *) + let dest = mk_place_from_var_id V.VarId.zero in + let ctx = assign_to_place config ctx box_v dest in + + (* Return *) + Ok ctx + | _ -> failwith "Inconsistent state" + +(** Auxiliary function which factorizes code to evaluate `std::Deref::deref` + and `std::DerefMut::deref_mut` - see [eval_non_local_function_call] *) +let eval_box_deref_mut_or_shared_concrete (config : C.config) + (region_params : T.erased_region list) (type_params : T.ety list) + (is_mut : bool) (ctx : C.eval_ctx) : C.eval_ctx eval_result = + (* Check the arguments *) + match (region_params, type_params, ctx.env) with + | ( [], + [ boxed_ty ], + Var (input_var, input_value) :: Var (_ret_var, _) :: C.Frame :: _ ) -> ( + (* Required type checking. We must have: + - input_value.ty == & (mut) Box + - boxed_ty == ty + for some ty + *) + (let _, input_ty, ref_kind = ty_get_ref input_value.V.ty in + assert (match ref_kind with T.Shared -> not is_mut | T.Mut -> is_mut); + let input_ty = ty_get_box input_ty in + assert (input_ty = boxed_ty)); + + (* Borrow the boxed value *) + let p = + { E.var_id = input_var.C.index; projection = [ E.Deref; E.DerefBox ] } + in + let borrow_kind = if is_mut then E.Mut else E.Shared in + let rv = E.Ref (p, borrow_kind) in + (* Note that the rvalue can't be a discriminant value *) + match eval_rvalue_non_discriminant config ctx rv with + | Error err -> Error err + | Ok (ctx, borrowed_value) -> + (* Move the borrowed value to its destination *) + let destp = mk_place_from_var_id V.VarId.zero in + let ctx = assign_to_place config ctx borrowed_value destp in + Ok ctx) + | _ -> failwith "Inconsistent state" + +(** Auxiliary function - see [eval_non_local_function_call] *) +let eval_box_deref_concrete (config : C.config) + (region_params : T.erased_region list) (type_params : T.ety list) + (ctx : C.eval_ctx) : C.eval_ctx eval_result = + let is_mut = false in + eval_box_deref_mut_or_shared_concrete config region_params type_params is_mut + ctx + +(** Auxiliary function - see [eval_non_local_function_call] *) +let eval_box_deref_mut_concrete (config : C.config) + (region_params : T.erased_region list) (type_params : T.ety list) + (ctx : C.eval_ctx) : C.eval_ctx eval_result = + let is_mut = true in + eval_box_deref_mut_or_shared_concrete config region_params type_params is_mut + ctx + +(** Auxiliary function - see [eval_non_local_function_call]. + + `Box::free` is not handled the same way as the other assumed functions: + - in the regular case, whenever we need to evaluate an assumed function, + we evaluate the operands, push a frame, call a dedicated function + to correctly update the variables in the frame (and mimic the execution + of a body) and finally pop the frame + - in the case of `Box::free`: the value given to this function is often + of the form `Box(⊥)` because we can move the value out of the + box before freeing the box. It makes it invalid to see box_free as a + "regular" function: it is not valid to call a function with arguments + which contain `⊥`. For this reason, we execute `Box::free` as drop_value, + but this is a bit annoying with regards to the semantics... + + Followingly this function doesn't behave like the others: it does not expect + a stack frame to have been pushed, but rather simply behaves like [drop_value]. + It thus updates the box value (by calling [drop_value]) and updates + the destination (by setting it to `()`). +*) +let eval_box_free (config : C.config) (region_params : T.erased_region list) + (type_params : T.ety list) (args : E.operand list) (dest : E.place) + (ctx : C.eval_ctx) : C.eval_ctx = + match (region_params, type_params, args) with + | [], [ boxed_ty ], [ E.Move input_box_place ] -> + (* Required type checking *) + let input_box = read_place_unwrap config Write input_box_place ctx in + (let input_ty = ty_get_box input_box.V.ty in + assert (input_ty = boxed_ty)); + + (* Drop the value *) + let ctx = drop_value config ctx input_box_place in + + (* Update the destination by setting it to `()` *) + let ctx = assign_to_place config ctx mk_unit_value dest in + + (* Return *) + ctx + | _ -> failwith "Inconsistent state" + +(** Auxiliary function - see [eval_non_local_function_call] *) +let eval_box_new_inst_sig (region_params : T.erased_region list) + (type_params : T.ety list) : A.inst_fun_sig = + (* The signature is: + `T -> Box` + where T is the type pram + *) + match (region_params, type_params) with + | [], [ ty_param ] -> + let input = ety_no_regions_to_rty ty_param in + let output = mk_box_ty ty_param in + let output = ety_no_regions_to_rty output in + { A.regions_hierarchy = []; inputs = [ input ]; output } + | _ -> failwith "Inconsistent state" + +(** Auxiliary function which factorizes code to evaluate `std::Deref::deref` + and `std::DerefMut::deref_mut` - see [eval_non_local_function_call] *) +let eval_box_deref_mut_or_shared_inst_sig (region_params : T.erased_region list) + (type_params : T.ety list) (is_mut : bool) (ctx : C.eval_ctx) : + C.eval_ctx * A.inst_fun_sig = + (* The signature is: + `&'a (mut) Box -> &'a (mut) T` + where T is the type param + *) + let ctx, rid = C.fresh_region_id ctx in + let r = T.Var rid in + let ctx, abs_id = C.fresh_abstraction_id ctx in + match (region_params, type_params) with + | [], [ ty_param ] -> + let ty_param = ety_no_regions_to_rty ty_param in + let ref_kind = if is_mut then T.Mut else T.Shared in + + let input = mk_box_ty ty_param in + let input = mk_ref_ty r input ref_kind in + + let output = mk_ref_ty r ty_param ref_kind in + + let regions = { A.id = abs_id; regions = [ rid ]; parents = [] } in + + let inst_sg = + { A.regions_hierarchy = [ regions ]; inputs = [ input ]; output } + in + + (ctx, inst_sg) + | _ -> failwith "Inconsistent state" + +(** Auxiliary function - see [eval_non_local_function_call] *) +let eval_box_deref_inst_sig (region_params : T.erased_region list) + (type_params : T.ety list) (ctx : C.eval_ctx) : C.eval_ctx * A.inst_fun_sig + = + let is_mut = false in + eval_box_deref_mut_or_shared_inst_sig region_params type_params is_mut ctx + +(** Auxiliary function - see [eval_non_local_function_call] *) +let eval_box_deref_mut_inst_sig (region_params : T.erased_region list) + (type_params : T.ety list) (ctx : C.eval_ctx) : C.eval_ctx * A.inst_fun_sig + = + let is_mut = true in + eval_box_deref_mut_or_shared_inst_sig region_params type_params is_mut ctx + +(** Evaluate a non-local function call in concrete mode *) +let eval_non_local_function_call_concrete (config : C.config) (ctx : C.eval_ctx) + (fid : A.assumed_fun_id) (region_params : T.erased_region list) + (type_params : T.ety list) (args : E.operand list) (dest : E.place) : + C.eval_ctx eval_result = + (* There are two cases (and this is extremely annoying): + - the function is not box_free + - the function is box_free + See [eval_box_free] + *) + match fid with + | A.BoxFree -> + (* Degenerate case: box_free *) + Ok (eval_box_free config region_params type_params args dest ctx) + | _ -> ( + (* "Normal" case: not box_free *) + (* Evaluate the operands *) + let ctx, args_vl = eval_operands config ctx args in + + (* Push the stack frame: we initialize the frame with the return variable, + and one variable per input argument *) + let ctx = ctx_push_frame ctx in + + (* Create and push the return variable *) + let ret_vid = V.VarId.zero in + let ret_ty = + get_non_local_function_return_type fid region_params type_params + in + let ret_var = mk_var ret_vid (Some "@return") ret_ty in + let ctx = C.ctx_push_uninitialized_var ctx ret_var in + + (* Create and push the input variables *) + let input_vars = + V.VarId.mapi_from1 + (fun id (v : V.typed_value) -> (mk_var id None v.V.ty, v)) + args_vl + in + let ctx = C.ctx_push_vars ctx input_vars in + + (* "Execute" the function body. As the functions are assumed, here we call + custom functions to perform the proper manipulations: we don't have + access to a body. *) + let res = + match fid with + | A.BoxNew -> eval_box_new_concrete config region_params type_params ctx + | A.BoxDeref -> + eval_box_deref_concrete config region_params type_params ctx + | A.BoxDerefMut -> + eval_box_deref_mut_concrete config region_params type_params ctx + | A.BoxFree -> failwith "Unreachable" + (* should have been treated above *) + in + + (* Check if the function body evaluated correctly *) + match res with + | Error err -> Error err + | Ok ctx -> + (* Pop the stack frame and retrieve the return value *) + let ctx, ret_value = ctx_pop_frame config ctx in + + (* Move the return value to its destination *) + let ctx = assign_to_place config ctx ret_value dest in + + (* Return *) + Ok ctx) + +(** Evaluate a statement *) +let rec eval_statement (config : C.config) (ctx : C.eval_ctx) (st : A.statement) + : (C.eval_ctx * statement_eval_res) eval_result list = + (* Debugging *) + L.log#ldebug + (lazy + ("\n" ^ eval_ctx_to_string ctx ^ "\nAbout to evaluate statement: " + ^ statement_to_string ctx st ^ "\n")); + (* Sanity check *) + if config.C.check_invariants then Inv.check_invariants ctx; + (* Evaluate *) + match st with + | A.Assign (p, rvalue) -> ( + (* Evaluate the rvalue *) + match eval_rvalue config ctx rvalue with + | Error err -> [ Error err ] + | Ok res -> + (* Assign *) + let assign (ctx, rvalue) = + let ctx = assign_to_place config ctx rvalue p in + Ok (ctx, Unit) + in + List.map assign res) + | A.FakeRead p -> + let ctx, _ = prepare_rplace config Read p ctx in + [ Ok (ctx, Unit) ] + | A.SetDiscriminant (p, variant_id) -> + [ Ok (set_discriminant config ctx p variant_id) ] + | A.Drop p -> [ Ok (drop_value config ctx p, Unit) ] + | A.Assert assertion -> ( + let ctx, v = eval_operand config ctx assertion.cond in + assert (v.ty = T.Bool); + match v.value with + | Concrete (Bool b) -> + if b = assertion.expected then [ Ok (ctx, Unit) ] else [ Error Panic ] + | _ -> failwith "Expected a boolean") + | A.Call call -> eval_function_call config ctx call + | A.Panic -> [ Error Panic ] + | A.Return -> [ Ok (ctx, Return) ] + | A.Break i -> [ Ok (ctx, Break i) ] + | A.Continue i -> [ Ok (ctx, Continue i) ] + | A.Nop -> [ Ok (ctx, Unit) ] + | A.Sequence (st1, st2) -> + (* Evaluate the first statement *) + let res1 = eval_statement config ctx st1 in + (* Evaluate the sequence *) + let eval_seq res1 = + match res1 with + | Error err -> [ Error err ] + | Ok (ctx, Unit) -> + (* Evaluate the second statement *) + eval_statement config ctx st2 + (* Control-flow break: transmit. We enumerate the cases on purpose *) + | Ok (ctx, Break i) -> [ Ok (ctx, Break i) ] + | Ok (ctx, Continue i) -> [ Ok (ctx, Continue i) ] + | Ok (ctx, Return) -> [ Ok (ctx, Return) ] + in + List.concat (List.map eval_seq res1) + | A.Loop loop_body -> + (* For now, we don't support loops in symbolic mode *) + assert (config.C.mode = C.ConcreteMode); + (* Evaluate a loop body + + We need a specific function for the [Continue] case: in case we continue, + we might have to reevaluate the current loop body with the new context + (and repeat this an indefinite number of times). + *) + let rec eval_loop_body (ctx : C.eval_ctx) : + (C.eval_ctx * statement_eval_res) eval_result list = + (* Evaluate the loop body *) + let body_res = eval_statement config ctx loop_body in + (* Evaluate the next steps *) + let eval res = + match res with + | Error err -> [ Error err ] + | Ok (ctx, Unit) -> + (* We finished evaluating the statement in a "normal" manner *) + [ Ok (ctx, Unit) ] + (* Control-flow breaks *) + | Ok (ctx, Break i) -> + (* Decrease the break index *) + if i = 0 then [ Ok (ctx, Unit) ] else [ Ok (ctx, Break (i - 1)) ] + | Ok (ctx, Continue i) -> + (* Decrease the continue index *) + if i = 0 then + (* We stop there. When we continue, we go back to the beginning + of the loop: we must thus reevaluate the loop body (and + recheck the result to know whether we must reevaluate again, + etc. *) + eval_loop_body ctx + else + (* We don't stop there: transmit *) + [ Ok (ctx, Continue (i - 1)) ] + | Ok (ctx, Return) -> [ Ok (ctx, Return) ] + in + List.concat (List.map eval body_res) + in + (* Apply *) + eval_loop_body ctx + | A.Switch (op, tgts) -> eval_switch config op tgts ctx + +(** Evaluate a switch *) +and eval_switch (config : C.config) (op : E.operand) (tgts : A.switch_targets) + (ctx : C.eval_ctx) : (C.eval_ctx * statement_eval_res) eval_result list = + (* We evaluate the operand in two steps: + * first we prepare it, then we check if its value is concrete or + * symbolic. If it is concrete, we can then evaluate the operand + * directly, otherwise we must first expand the value. + * Note that we can't fully evaluate the operand *then* expand the + * value if it is symbolic, because the value may have been move + * (and would thus floating in thin air...)! + * *) + (* Prepare the operand *) + let ctx, op_v = eval_operand_prepare config ctx op in + (* Match on the targets *) + match tgts with + | A.If (st1, st2) -> ( + match op_v.value with + | V.Concrete (V.Bool b) -> + (* Evaluate the operand *) + let ctx, op_v' = eval_operand config ctx op in + assert (op_v' = op_v); + (* Branch *) + if b then eval_statement config ctx st1 + else eval_statement config ctx st2 + | V.Symbolic sv -> + (* Synthesis *) + S.synthesize_symbolic_expansion_if_branching sv.V.svalue; + (* Expand the symbolic value to true or false *) + let see_true = SeConcrete (V.Bool true) in + let see_false = SeConcrete (V.Bool false) in + let expand_and_execute see st = + (* Apply the symbolic expansion *) + let ctx = + apply_symbolic_expansion_non_borrow config sv.V.svalue see ctx + in + (* Evaluate the operand *) + let ctx, _ = eval_operand config ctx op in + (* Evaluate the branch *) + eval_statement config ctx st + in + (* Execute the two branches *) + List.append + (expand_and_execute see_true st1) + (expand_and_execute see_false st2) + | _ -> failwith "Inconsistent state") + | A.SwitchInt (int_ty, tgts, otherwise) -> ( + match op_v.value with + | V.Concrete (V.Scalar sv) -> ( + (* Evaluate the operand *) + let ctx, op_v' = eval_operand config ctx op in + assert (op_v' = op_v); + (* Sanity check *) + assert (sv.V.int_ty = int_ty); + (* Find the branch *) + match List.find_opt (fun (sv', _) -> sv = sv') tgts with + | None -> eval_statement config ctx otherwise + | Some (_, tgt) -> eval_statement config ctx tgt) + | V.Symbolic sv -> + (* Synthesis *) + S.synthesize_symbolic_expansion_switch_int_branching sv.V.svalue; + (* For all the branches of the switch, we expand the symbolic value + * to the value given by the branch and execute the branch statement. + * For the otherwise branch, we leave the symbolic value as it is + * (because this branch doesn't precisely define which should be the + * value of the scrutinee...) and simply execute the otherwise statement. + *) + (* Branches other than "otherwise" *) + let exec_branch (switch_value, branch_st) = + let see = SeConcrete (V.Scalar switch_value) in + (* Apply the symbolic expansion *) + let ctx = + apply_symbolic_expansion_non_borrow config sv.V.svalue see ctx + in + (* Evaluate the operand *) + let ctx, _ = eval_operand config ctx op in + (* Evaluate the branch *) + eval_statement config ctx branch_st + in + let ctxl = List.map exec_branch tgts in + (* Otherwise branch *) + let ctx_otherwise = eval_statement config ctx otherwise in + (* Put everything together *) + List.append (List.concat ctxl) ctx_otherwise + | _ -> failwith "Inconsistent state") + +(** Evaluate a function call (auxiliary helper for [eval_statement]) *) +and eval_function_call (config : C.config) (ctx : C.eval_ctx) (call : A.call) : + (C.eval_ctx * statement_eval_res) eval_result list = + (* There are two cases * + - this is a local function, in which case we execute its body + - this is a non-local function, in which case there is a special treatment + *) + let res = + match call.func with + | A.Local fid -> + eval_local_function_call config ctx fid call.region_params + call.type_params call.args call.dest + | A.Assumed fid -> + [ + eval_non_local_function_call config ctx fid call.region_params + call.type_params call.args call.dest; + ] + in + List.map + (fun res -> + match res with Error err -> Error err | Ok ctx -> Ok (ctx, Unit)) + res + +(** Evaluate a local (i.e., non-assumed) function call in concrete mode *) +and eval_local_function_call_concrete (config : C.config) (ctx : C.eval_ctx) + (fid : A.FunDefId.id) (_region_params : T.erased_region list) + (type_params : T.ety list) (args : E.operand list) (dest : E.place) : + C.eval_ctx eval_result list = + (* Retrieve the (correctly instantiated) body *) + let def = C.ctx_lookup_fun_def ctx fid in + let tsubst = + Subst.make_type_subst + (List.map (fun v -> v.T.index) def.A.signature.type_params) + type_params + in + let locals, body = Subst.fun_def_substitute_in_body tsubst def in + + (* Evaluate the input operands *) + let ctx, args = eval_operands config ctx args in + assert (List.length args = def.A.arg_count); + + (* Push a frame delimiter *) + let ctx = ctx_push_frame ctx in + + (* Compute the initial values for the local variables *) + (* 1. Push the return value *) + let ret_var, locals = + match locals with + | ret_ty :: locals -> (ret_ty, locals) + | _ -> failwith "Unreachable" + in + let ctx = C.ctx_push_var ctx ret_var (C.mk_bottom ret_var.var_ty) in + + (* 2. Push the input values *) + let input_locals, locals = Utilities.list_split_at locals def.A.arg_count in + let inputs = List.combine input_locals args in + (* Note that this function checks that the variables and their values + have the same type (this is important) *) + let ctx = C.ctx_push_vars ctx inputs in + + (* 3. Push the remaining local variables (initialized as [Bottom]) *) + let ctx = C.ctx_push_uninitialized_vars ctx locals in + + (* Execute the function body *) + let res = eval_function_body config ctx body in + + (* Pop the stack frame and move the return value to its destination *) + let finish res = + match res with + | Error Panic -> Error Panic + | Ok ctx -> + (* Pop the stack frame and retrieve the return value *) + let ctx, ret_value = ctx_pop_frame config ctx in + + (* Move the return value to its destination *) + let ctx = assign_to_place config ctx ret_value dest in + + (* Return *) + Ok ctx + in + List.map finish res + +(** Evaluate a local (i.e., non-assumed) function call in symbolic mode *) +and eval_local_function_call_symbolic (config : C.config) (ctx : C.eval_ctx) + (fid : A.FunDefId.id) (region_params : T.erased_region list) + (type_params : T.ety list) (args : E.operand list) (dest : E.place) : + C.eval_ctx = + (* Retrieve the (correctly instantiated) signature *) + let def = C.ctx_lookup_fun_def ctx fid in + let sg = def.A.signature in + (* Generate fresh abstraction ids and create a substitution from region + * group ids to abstraction ids *) + let ctx, rg_abs_ids_bindings = + List.fold_left_map + (fun ctx rg -> + let ctx, abs_id = C.fresh_abstraction_id ctx in + (ctx, (rg.A.id, abs_id))) + ctx sg.regions_hierarchy + in + let asubst_map : V.AbstractionId.id A.RegionGroupId.Map.t = + List.fold_left + (fun mp (rg_id, abs_id) -> A.RegionGroupId.Map.add rg_id abs_id mp) + A.RegionGroupId.Map.empty rg_abs_ids_bindings + in + let asubst (rg_id : A.RegionGroupId.id) : V.AbstractionId.id = + A.RegionGroupId.Map.find rg_id asubst_map + in + (* Generate fresh regions and their substitutions *) + let ctx, _, rsubst, _ = + Subst.fresh_regions_with_substs sg.region_params ctx + in + (* Generate the type substitution + * Note that we need the substitution to map the type variables to + * [rty] types (not [ety]). In order to do that, we convert the + * type parameters to types with regions. This is possible only + * if those types don't contain any regions. + * This is a current limitation of the analysis: there is still some + * work to do to properly handle full type parametrization. + * *) + let rtype_params = List.map ety_no_regions_to_rty type_params in + let tsubst = + Subst.make_type_subst + (List.map (fun v -> v.T.index) sg.type_params) + rtype_params + in + (* Substitute the signature *) + let inst_sg = Subst.substitute_signature asubst rsubst tsubst sg in + (* Sanity check *) + assert (List.length args = def.A.arg_count); + (* Evaluate the function call *) + eval_function_call_symbolic_from_inst_sig config ctx (A.Local fid) inst_sg + region_params type_params args dest + +(** Evaluate a function call in symbolic mode by using the function signature. + + This allows us to factorize the evaluation of local and non-local function + calls in symbolic mode: only their signatures matter. + *) +and eval_function_call_symbolic_from_inst_sig (config : C.config) + (ctx : C.eval_ctx) (fid : A.fun_id) (inst_sg : A.inst_fun_sig) + (region_params : T.erased_region list) (type_params : T.ety list) + (args : E.operand list) (dest : E.place) : C.eval_ctx = + (* Generate a fresh symbolic value for the return value *) + let ret_sv_ty = inst_sg.A.output in + let ctx, ret_spc = + mk_fresh_symbolic_proj_comp T.RegionId.Set.empty ret_sv_ty ctx + in + let ret_value = mk_typed_value_from_proj_comp ret_spc in + let ret_av = V.ASymbolic (V.AProjLoans ret_spc.V.svalue) in + let ret_av : V.typed_avalue = + { V.value = ret_av; V.ty = ret_spc.V.svalue.V.sv_ty } + in + (* Evaluate the input operands *) + let ctx, args = eval_operands config ctx args in + let args_with_rtypes = List.combine args inst_sg.A.inputs in + (* Check the type of the input arguments *) + assert ( + List.for_all + (fun ((arg, rty) : V.typed_value * T.rty) -> + arg.V.ty = Subst.erase_regions rty) + args_with_rtypes); + (* Generate the abstractions from the region groups and add them to the context *) + let gen_abs (ctx : C.eval_ctx) (rg : A.abs_region_group) : C.eval_ctx = + let abs_id = rg.A.id in + let parents = + List.fold_left + (fun s pid -> V.AbstractionId.Set.add pid s) + V.AbstractionId.Set.empty rg.A.parents + in + let regions = + List.fold_left + (fun s rid -> T.RegionId.Set.add rid s) + T.RegionId.Set.empty rg.A.regions + in + (* Project over the input values *) + let ctx, args_projs = + List.fold_left_map + (fun ctx (arg, arg_rty) -> + apply_proj_borrows_on_input_value config ctx regions arg arg_rty) + ctx args_with_rtypes + in + (* Group the input and output values *) + let avalues = List.append args_projs [ ret_av ] in + (* Create the abstraction *) + let abs = { V.abs_id; parents; regions; avalues } in + (* Insert the abstraction in the context *) + let ctx = { ctx with env = Abs abs :: ctx.env } in + (* Return *) + ctx + in + let ctx = List.fold_left gen_abs ctx inst_sg.A.regions_hierarchy in + (* Move the return value to its destination *) + let ctx = assign_to_place config ctx ret_value dest in + (* Synthesis *) + S.synthesize_function_call fid region_params type_params args dest + ret_spc.V.svalue; + (* Return *) + ctx + +(** Evaluate a non-local function call in symbolic mode *) +and eval_non_local_function_call_symbolic (config : C.config) (ctx : C.eval_ctx) + (fid : A.assumed_fun_id) (region_params : T.erased_region list) + (type_params : T.ety list) (args : E.operand list) (dest : E.place) : + C.eval_ctx = + (* Sanity check: make sure the type parameters don't contain regions - + * this is a current limitation of our synthesis *) + assert (List.for_all (fun ty -> not (ty_has_regions ty)) type_params); + + (* There are two cases (and this is extremely annoying): + - the function is not box_free + - the function is box_free + See [eval_box_free] + *) + match fid with + | A.BoxFree -> + (* Degenerate case: box_free - note that this is not really a function + * call: no need to call a "synthesize_..." function *) + eval_box_free config region_params type_params args dest ctx + | _ -> + (* "Normal" case: not box_free *) + (* In symbolic mode, the behaviour of a function call is completely defined + * by the signature of the function: we thus simply generate correctly + * instantiated signatures, and delegate the work to an auxiliary function *) + let ctx, inst_sig = + match fid with + | A.BoxNew -> (ctx, eval_box_new_inst_sig region_params type_params) + | A.BoxDeref -> eval_box_deref_inst_sig region_params type_params ctx + | A.BoxDerefMut -> + eval_box_deref_mut_inst_sig region_params type_params ctx + | A.BoxFree -> failwith "Unreachable" + (* should have been treated above *) + in + + (* Evaluate the function call *) + eval_function_call_symbolic_from_inst_sig config ctx (A.Assumed fid) + inst_sig region_params type_params args dest + +(** Evaluate a non-local (i.e, assumed) function call such as `Box::deref` + (auxiliary helper for [eval_statement]) *) +and eval_non_local_function_call (config : C.config) (ctx : C.eval_ctx) + (fid : A.assumed_fun_id) (region_params : T.erased_region list) + (type_params : T.ety list) (args : E.operand list) (dest : E.place) : + C.eval_ctx eval_result = + (* Debug *) + L.log#ldebug + (lazy + (let type_params = + "[" + ^ String.concat ", " (List.map (ety_to_string ctx) type_params) + ^ "]" + in + let args = + "[" ^ String.concat ", " (List.map (operand_to_string ctx) args) ^ "]" + in + let dest = place_to_string ctx dest in + "eval_non_local_function_call:\n- fid:" ^ A.show_assumed_fun_id fid + ^ "\n- type_params: " ^ type_params ^ "\n- args: " ^ args ^ "\n- dest: " + ^ dest)); + + match config.mode with + | C.ConcreteMode -> + eval_non_local_function_call_concrete config ctx fid region_params + type_params args dest + | C.SymbolicMode -> + Ok + (eval_non_local_function_call_symbolic config ctx fid region_params + type_params args dest) + +(** Evaluate a local (i.e, not assumed) function call (auxiliary helper for + [eval_statement]) *) +and eval_local_function_call (config : C.config) (ctx : C.eval_ctx) + (fid : A.FunDefId.id) (region_params : T.erased_region list) + (type_params : T.ety list) (args : E.operand list) (dest : E.place) : + C.eval_ctx eval_result list = + match config.mode with + | ConcreteMode -> + eval_local_function_call_concrete config ctx fid region_params type_params + args dest + | SymbolicMode -> + [ + Ok + (eval_local_function_call_symbolic config ctx fid region_params + type_params args dest); + ] + +(** Evaluate a statement seen as a function body (auxiliary helper for + [eval_statement]) *) +and eval_function_body (config : C.config) (ctx : C.eval_ctx) + (body : A.statement) : (C.eval_ctx, eval_error) result list = + let res = eval_statement config ctx body in + let finish res = + match res with + | Error err -> Error err + | Ok (ctx, res) -> ( + (* Sanity check *) + if config.C.check_invariants then Inv.check_invariants ctx; + match res with + | Unit | Break _ | Continue _ -> failwith "Inconsistent state" + | Return -> Ok ctx) + in + List.map finish res -- cgit v1.2.3 From 9de2ecb71504ff0c31f0825dbe5d54ddf3d9d4a1 Mon Sep 17 00:00:00 2001 From: Son Ho Date: Thu, 6 Jan 2022 10:43:08 +0100 Subject: Move some definitions --- src/InterpreterExpressions.ml | 20 -------------------- src/InterpreterStatements.ml | 20 ++++++++++++++++++++ 2 files changed, 20 insertions(+), 20 deletions(-) (limited to 'src') diff --git a/src/InterpreterExpressions.ml b/src/InterpreterExpressions.ml index 83651ba5..1b2a9859 100644 --- a/src/InterpreterExpressions.ml +++ b/src/InterpreterExpressions.ml @@ -31,26 +31,6 @@ let prepare_rplace (config : C.config) (access : access_kind) (p : E.place) let v = read_place_unwrap config access p ctx in (ctx, v) -(** Drop a value at a given place *) -let drop_value (config : C.config) (ctx : C.eval_ctx) (p : E.place) : C.eval_ctx - = - L.log#ldebug (lazy ("drop_value: place: " ^ place_to_string ctx p)); - (* Prepare the place (by ending the loans, then the borrows) *) - let ctx, v = prepare_lplace config p ctx in - (* Replace the value with [Bottom] *) - let nv = { v with value = V.Bottom } in - let ctx = write_place_unwrap config Write p nv ctx in - ctx - -(** Assign a value to a given place *) -let assign_to_place (config : C.config) (ctx : C.eval_ctx) (v : V.typed_value) - (p : E.place) : C.eval_ctx = - (* Prepare the destination *) - let ctx, _ = prepare_lplace config p ctx in - (* Update the destination *) - let ctx = write_place_unwrap config Write p v ctx in - ctx - (** Convert a constant operand value to a typed value *) let constant_value_to_typed_value (ctx : C.eval_ctx) (ty : T.ety) (cv : E.operand_constant_value) : V.typed_value = diff --git a/src/InterpreterStatements.ml b/src/InterpreterStatements.ml index ec61b5e0..d52ec0e7 100644 --- a/src/InterpreterStatements.ml +++ b/src/InterpreterStatements.ml @@ -22,6 +22,26 @@ open InterpreterExpressions (** Result of evaluating a statement *) type statement_eval_res = Unit | Break of int | Continue of int | Return +(** Drop a value at a given place *) +let drop_value (config : C.config) (ctx : C.eval_ctx) (p : E.place) : C.eval_ctx + = + L.log#ldebug (lazy ("drop_value: place: " ^ place_to_string ctx p)); + (* Prepare the place (by ending the loans, then the borrows) *) + let ctx, v = prepare_lplace config p ctx in + (* Replace the value with [Bottom] *) + let nv = { v with value = V.Bottom } in + let ctx = write_place_unwrap config Write p nv ctx in + ctx + +(** Assign a value to a given place *) +let assign_to_place (config : C.config) (ctx : C.eval_ctx) (v : V.typed_value) + (p : E.place) : C.eval_ctx = + (* Prepare the destination *) + let ctx, _ = prepare_lplace config p ctx in + (* Update the destination *) + let ctx = write_place_unwrap config Write p v ctx in + ctx + (** Updates the discriminant of a value at a given place. There are two situations: -- cgit v1.2.3 From 8cac3c5cb5f9c36ffa878cf32ce858d171e4e3c8 Mon Sep 17 00:00:00 2001 From: Son Ho Date: Thu, 6 Jan 2022 10:52:37 +0100 Subject: Cleanup the dependencies a bit --- src/Interpreter.ml | 18 ------------------ src/InterpreterBorrows.ml | 4 ---- src/InterpreterExpansion.ml | 3 --- src/InterpreterExpressions.ml | 5 ----- src/InterpreterPaths.ml | 7 ------- src/InterpreterProjectors.ml | 2 -- src/InterpreterStatements.ml | 4 ---- src/InterpreterUtils.ml | 2 -- src/Modules.ml | 1 - src/Synthesis.ml | 5 ----- 10 files changed, 51 deletions(-) (limited to 'src') diff --git a/src/Interpreter.ml b/src/Interpreter.ml index f3e94dbe..e74aa1e7 100644 --- a/src/Interpreter.ml +++ b/src/Interpreter.ml @@ -1,22 +1,4 @@ -module T = Types -module V = Values -open Scalars -module E = Expressions -open Errors -module C = Contexts -module Subst = Substitute -module A = CfimAst module L = Logging -open TypesUtils -open ValuesUtils -module Inv = Invariants -module S = Synthesis -open Utils -open InterpreterUtils -open InterpreterProjectors -open InterpreterBorrows -open InterpreterExpansion -open InterpreterPaths open InterpreterExpressions open InterpreterStatements diff --git a/src/InterpreterBorrows.ml b/src/InterpreterBorrows.ml index e8503d57..33501939 100644 --- a/src/InterpreterBorrows.ml +++ b/src/InterpreterBorrows.ml @@ -1,14 +1,10 @@ module T = Types module V = Values -open Scalars module E = Expressions -open Errors module C = Contexts module Subst = Substitute module A = CfimAst module L = Logging -open TypesUtils -open ValuesUtils module Inv = Invariants module S = Synthesis open Utils diff --git a/src/InterpreterExpansion.ml b/src/InterpreterExpansion.ml index 7b249717..30be657f 100644 --- a/src/InterpreterExpansion.ml +++ b/src/InterpreterExpansion.ml @@ -5,9 +5,7 @@ module T = Types module V = Values -open Scalars module E = Expressions -open Errors module C = Contexts module Subst = Substitute module A = CfimAst @@ -16,7 +14,6 @@ open TypesUtils open ValuesUtils module Inv = Invariants module S = Synthesis -open Utils open InterpreterUtils open InterpreterProjectors open InterpreterBorrows diff --git a/src/InterpreterExpressions.ml b/src/InterpreterExpressions.ml index 1b2a9859..b08c8749 100644 --- a/src/InterpreterExpressions.ml +++ b/src/InterpreterExpressions.ml @@ -5,16 +5,11 @@ module E = Expressions open Errors module C = Contexts module Subst = Substitute -module A = CfimAst module L = Logging -open TypesUtils open ValuesUtils module Inv = Invariants module S = Synthesis -open Utils open InterpreterUtils -open InterpreterProjectors -open InterpreterBorrows open InterpreterExpansion open InterpreterPaths diff --git a/src/InterpreterPaths.ml b/src/InterpreterPaths.ml index 7e9fa7dd..fa9fe1a8 100644 --- a/src/InterpreterPaths.ml +++ b/src/InterpreterPaths.ml @@ -1,19 +1,12 @@ module T = Types module V = Values -open Scalars module E = Expressions -open Errors module C = Contexts module Subst = Substitute -module A = CfimAst module L = Logging -open TypesUtils -open ValuesUtils module Inv = Invariants module S = Synthesis -open Utils open InterpreterUtils -open InterpreterProjectors open InterpreterBorrows open InterpreterExpansion diff --git a/src/InterpreterProjectors.ml b/src/InterpreterProjectors.ml index 9c99f8c9..9a487c89 100644 --- a/src/InterpreterProjectors.ml +++ b/src/InterpreterProjectors.ml @@ -1,8 +1,6 @@ module T = Types module V = Values -open Scalars module E = Expressions -open Errors module C = Contexts module Subst = Substitute module A = CfimAst diff --git a/src/InterpreterStatements.ml b/src/InterpreterStatements.ml index d52ec0e7..91035574 100644 --- a/src/InterpreterStatements.ml +++ b/src/InterpreterStatements.ml @@ -1,8 +1,6 @@ module T = Types module V = Values -open Scalars module E = Expressions -open Errors module C = Contexts module Subst = Substitute module A = CfimAst @@ -11,10 +9,8 @@ open TypesUtils open ValuesUtils module Inv = Invariants module S = Synthesis -open Utils open InterpreterUtils open InterpreterProjectors -open InterpreterBorrows open InterpreterExpansion open InterpreterPaths open InterpreterExpressions diff --git a/src/InterpreterUtils.ml b/src/InterpreterUtils.ml index dc5a0477..be3d606c 100644 --- a/src/InterpreterUtils.ml +++ b/src/InterpreterUtils.ml @@ -2,9 +2,7 @@ module T = Types module V = Values -open Scalars module E = Expressions -open Errors module C = Contexts module Subst = Substitute module A = CfimAst diff --git a/src/Modules.ml b/src/Modules.ml index 5b76880f..bf5e9835 100644 --- a/src/Modules.ml +++ b/src/Modules.ml @@ -1,4 +1,3 @@ -open Yojson.Basic open Types open CfimAst diff --git a/src/Synthesis.ml b/src/Synthesis.ml index d240714e..de482b18 100644 --- a/src/Synthesis.ml +++ b/src/Synthesis.ml @@ -1,15 +1,10 @@ module T = Types module V = Values -open Scalars module E = Expressions -open Errors module C = Contexts module Subst = Substitute module A = CfimAst module L = Logging -open TypesUtils -open ValuesUtils -module Inv = Invariants open InterpreterUtils (* TODO: the below functions have very "rough" signatures and do nothing: I -- cgit v1.2.3 From 6a3faa82e09e3fbf23014b53a2b40d420bc70c9b Mon Sep 17 00:00:00 2001 From: Son Ho Date: Thu, 6 Jan 2022 11:01:44 +0100 Subject: Cleanup a bit more the dependencies and activate more warnings/errors --- src/InterpreterBorrows.ml | 4 ---- src/InterpreterExpansion.ml | 1 - src/InterpreterPaths.ml | 1 - src/InterpreterProjectors.ml | 5 +---- src/dune | 4 ++-- 5 files changed, 3 insertions(+), 12 deletions(-) (limited to 'src') diff --git a/src/InterpreterBorrows.ml b/src/InterpreterBorrows.ml index 33501939..b60f0973 100644 --- a/src/InterpreterBorrows.ml +++ b/src/InterpreterBorrows.ml @@ -1,12 +1,8 @@ module T = Types module V = Values -module E = Expressions module C = Contexts module Subst = Substitute -module A = CfimAst module L = Logging -module Inv = Invariants -module S = Synthesis open Utils open InterpreterUtils open InterpreterProjectors diff --git a/src/InterpreterExpansion.ml b/src/InterpreterExpansion.ml index 30be657f..46398c84 100644 --- a/src/InterpreterExpansion.ml +++ b/src/InterpreterExpansion.ml @@ -8,7 +8,6 @@ module V = Values module E = Expressions module C = Contexts module Subst = Substitute -module A = CfimAst module L = Logging open TypesUtils open ValuesUtils diff --git a/src/InterpreterPaths.ml b/src/InterpreterPaths.ml index fa9fe1a8..e8f5eefc 100644 --- a/src/InterpreterPaths.ml +++ b/src/InterpreterPaths.ml @@ -4,7 +4,6 @@ module E = Expressions module C = Contexts module Subst = Substitute module L = Logging -module Inv = Invariants module S = Synthesis open InterpreterUtils open InterpreterBorrows diff --git a/src/InterpreterProjectors.ml b/src/InterpreterProjectors.ml index 9a487c89..c3fd0708 100644 --- a/src/InterpreterProjectors.ml +++ b/src/InterpreterProjectors.ml @@ -3,12 +3,9 @@ module V = Values module E = Expressions module C = Contexts module Subst = Substitute -module A = CfimAst module L = Logging open TypesUtils open ValuesUtils -module Inv = Invariants -module S = Synthesis open Utils open InterpreterUtils @@ -24,7 +21,7 @@ let rec apply_proj_borrows_on_shared_borrow (ctx : C.eval_ctx) V.abstract_shared_borrows = (* Sanity check - TODO: move this elsewhere (here we perform the check at every * recursive call which is a bit overkill...) *) - let ety = Substitute.erase_regions ty in + let ety = Subst.erase_regions ty in assert (ety = v.V.ty); (* Project *) match (v.V.value, ty) with diff --git a/src/dune b/src/dune index eab08028..151b2f70 100644 --- a/src/dune +++ b/src/dune @@ -9,12 +9,12 @@ -safe-string -g ;-dsource - -warn-error -9-11-33-20-21-26-27-39 + -warn-error -5-8-9-11-14-33-20-21-26-27-39 )) (release (flags :standard -safe-string -g ;-dsource - -warn-error -9-11-33-20-21-26-27-39 + -warn-error -5-8-9-11-14-33-20-21-26-27-39 ))) -- cgit v1.2.3 From 6ef1bf7e2f1b7a0067169bf71860671f8b3f6bca Mon Sep 17 00:00:00 2001 From: Son Ho Date: Thu, 6 Jan 2022 11:20:38 +0100 Subject: Cleanup and reorganize --- src/InterpreterBorrows.ml | 1 + src/InterpreterBorrowsCore.ml | 459 ++++++++++++++++++++++++++++++++++++++++ src/InterpreterPaths.ml | 1 + src/InterpreterProjectors.ml | 1 + src/InterpreterUtils.ml | 475 +----------------------------------------- src/Invariants.ml | 1 + src/TypesUtils.ml | 20 ++ src/ValuesUtils.ml | 10 +- 8 files changed, 492 insertions(+), 476 deletions(-) create mode 100644 src/InterpreterBorrowsCore.ml (limited to 'src') diff --git a/src/InterpreterBorrows.ml b/src/InterpreterBorrows.ml index b60f0973..38c79b66 100644 --- a/src/InterpreterBorrows.ml +++ b/src/InterpreterBorrows.ml @@ -5,6 +5,7 @@ module Subst = Substitute module L = Logging open Utils open InterpreterUtils +open InterpreterBorrowsCore open InterpreterProjectors (** Auxiliary function to end borrows: lookup a borrow in the environment, diff --git a/src/InterpreterBorrowsCore.ml b/src/InterpreterBorrowsCore.ml new file mode 100644 index 00000000..ccc259f5 --- /dev/null +++ b/src/InterpreterBorrowsCore.ml @@ -0,0 +1,459 @@ +(* This file defines the basic blocks to implement the semantics of borrows. + * Note that those functions are not only used in InterpreterBorrows, but + * also in Invariants or InterpreterProjectors *) + +module T = Types +module V = Values +module C = Contexts +module Subst = Substitute +module L = Logging +open Utils +open InterpreterUtils + +(** TODO: cleanup this a bit, once we have a better understanding about + what we need. + TODO: I'm not sure in which file this should be moved... *) +type exploration_kind = { + enter_shared_loans : bool; + enter_mut_borrows : bool; + enter_abs : bool; + (** Note that if we allow to enter abs, we don't check whether we enter + mutable/shared loans or borrows: there are no use cases requiring + a finer control. *) +} +(** This record controls how some generic helper lookup/update + functions behave, by restraining the kind of therms they can enter. +*) + +let ek_all : exploration_kind = + { enter_shared_loans = true; enter_mut_borrows = true; enter_abs = true } + +(** The following type identifies the relative position of expressions (in + particular borrows) in other expressions. + + For instance, it is used to control [end_borrow]: we usually only allow + to end "outer" borrows, unless we perform a drop. +*) +type inner_outer = Inner | Outer + +type borrow_ids = Borrows of V.BorrowId.Set.t | Borrow of V.BorrowId.id + +exception FoundBorrowIds of borrow_ids + +type outer_borrows_or_abs = + | OuterBorrows of borrow_ids + | OuterAbs of V.AbstractionId.id + +let update_if_none opt x = match opt with None -> Some x | _ -> opt + +exception FoundOuter of outer_borrows_or_abs +(** Utility exception *) + +(** Lookup a loan content. + + The loan is referred to by a borrow id. + + TODO: group abs_or_var_id and g_loan_content. + *) +let lookup_loan_opt (ek : exploration_kind) (l : V.BorrowId.id) + (ctx : C.eval_ctx) : (abs_or_var_id * g_loan_content) option = + (* We store here whether we are inside an abstraction or a value - note that we + * could also track that with the environment, it would probably be more idiomatic + * and cleaner *) + let abs_or_var : abs_or_var_id option ref = ref None in + + let obj = + object + inherit [_] C.iter_eval_ctx as super + + method! visit_borrow_content env bc = + match bc with + | V.SharedBorrow bid -> + (* Nothing specific to do *) + super#visit_SharedBorrow env bid + | V.InactivatedMutBorrow bid -> + (* Nothing specific to do *) + super#visit_InactivatedMutBorrow env bid + | V.MutBorrow (bid, mv) -> + (* Control the dive *) + if ek.enter_mut_borrows then super#visit_MutBorrow env bid mv + else () + + method! visit_loan_content env lc = + match lc with + | V.SharedLoan (bids, sv) -> + (* Check if this is the loan we are looking for, and control the dive *) + if V.BorrowId.Set.mem l bids then + raise (FoundGLoanContent (Concrete lc)) + else if ek.enter_shared_loans then + super#visit_SharedLoan env bids sv + else () + | V.MutLoan bid -> + (* Check if this is the loan we are looking for *) + if bid = l then raise (FoundGLoanContent (Concrete lc)) + else super#visit_MutLoan env bid + (** We reimplement [visit_Loan] (rather than the more precise functions + [visit_SharedLoan], etc.) on purpose: as we have an exhaustive match + below, we are more resilient to definition updates (the compiler + is our friend). + *) + + method! visit_aloan_content env lc = + match lc with + | V.AMutLoan (bid, av) -> + if bid = l then raise (FoundGLoanContent (Abstract lc)) + else super#visit_AMutLoan env bid av + | V.ASharedLoan (bids, v, av) -> + if V.BorrowId.Set.mem l bids then + raise (FoundGLoanContent (Abstract lc)) + else super#visit_ASharedLoan env bids v av + | V.AEndedMutLoan { given_back; child } -> + super#visit_AEndedMutLoan env given_back child + | V.AEndedSharedLoan (v, av) -> super#visit_AEndedSharedLoan env v av + | V.AIgnoredMutLoan (bid, av) -> super#visit_AIgnoredMutLoan env bid av + | V.AEndedIgnoredMutLoan { given_back; child } -> + super#visit_AEndedIgnoredMutLoan env given_back child + | V.AIgnoredSharedLoan av -> super#visit_AIgnoredSharedLoan env av + (** Note that we don't control diving inside the abstractions: if we + allow to dive inside abstractions, we allow to go anywhere + (because there are no use cases requiring finer control) *) + + method! visit_Var env bv v = + assert (Option.is_none !abs_or_var); + abs_or_var := Some (VarId bv.C.index); + super#visit_Var env bv v; + abs_or_var := None + + method! visit_Abs env abs = + assert (Option.is_none !abs_or_var); + if ek.enter_abs then ( + abs_or_var := Some (AbsId abs.V.abs_id); + super#visit_Abs env abs) + else () + end + in + (* We use exceptions *) + try + obj#visit_eval_ctx () ctx; + None + with FoundGLoanContent lc -> ( + match !abs_or_var with + | Some abs_or_var -> Some (abs_or_var, lc) + | None -> failwith "Inconsistent state") + +(** Lookup a loan content. + + The loan is referred to by a borrow id. + Raises an exception if no loan was found. + *) +let lookup_loan (ek : exploration_kind) (l : V.BorrowId.id) (ctx : C.eval_ctx) : + abs_or_var_id * g_loan_content = + match lookup_loan_opt ek l ctx with + | None -> failwith "Unreachable" + | Some res -> res + +(** Update a loan content. + + The loan is referred to by a borrow id. + + This is a helper function: it might break invariants. + *) +let update_loan (ek : exploration_kind) (l : V.BorrowId.id) + (nlc : V.loan_content) (ctx : C.eval_ctx) : C.eval_ctx = + (* We use a reference to check that we update exactly one loan: when updating + * inside values, we check we don't update more than one loan. Then, upon + * returning we check that we updated at least once. *) + let r = ref false in + let update () : V.loan_content = + assert (not !r); + r := true; + nlc + in + + let obj = + object + inherit [_] C.map_eval_ctx as super + + method! visit_borrow_content env bc = + match bc with + | V.SharedBorrow _ | V.InactivatedMutBorrow _ -> + (* Nothing specific to do *) + super#visit_borrow_content env bc + | V.MutBorrow (bid, mv) -> + (* Control the dive into mutable borrows *) + if ek.enter_mut_borrows then super#visit_MutBorrow env bid mv + else V.MutBorrow (bid, mv) + + method! visit_loan_content env lc = + match lc with + | V.SharedLoan (bids, sv) -> + (* Shared loan: check if this is the loan we are looking for, and + control the dive. *) + if V.BorrowId.Set.mem l bids then update () + else if ek.enter_shared_loans then + super#visit_SharedLoan env bids sv + else V.SharedLoan (bids, sv) + | V.MutLoan bid -> + (* Mut loan: checks if this is the loan we are looking for *) + if bid = l then update () else super#visit_MutLoan env bid + (** We reimplement [visit_loan_content] (rather than one of the sub- + functions) on purpose: exhaustive matches are good for maintenance *) + + method! visit_abs env abs = + if ek.enter_abs then super#visit_abs env abs else abs + (** Note that once inside the abstractions, we don't control diving + (there are no use cases requiring finer control). + Also, as we give back a [loan_content] (and not an [aloan_content]) + we don't need to do reimplement the visit functions for the values + inside the abstractions (rk.: there may be "concrete" values inside + abstractions, so there is a utility in diving inside). *) + end + in + + let ctx = obj#visit_eval_ctx () ctx in + (* Check that we updated at least one loan *) + assert !r; + ctx + +(** Update a abstraction loan content. + + The loan is referred to by a borrow id. + + This is a helper function: it might break invariants. + *) +let update_aloan (ek : exploration_kind) (l : V.BorrowId.id) + (nlc : V.aloan_content) (ctx : C.eval_ctx) : C.eval_ctx = + (* We use a reference to check that we update exactly one loan: when updating + * inside values, we check we don't update more than one loan. Then, upon + * returning we check that we updated at least once. *) + let r = ref false in + let update () : V.aloan_content = + assert (not !r); + r := true; + nlc + in + + let obj = + object + inherit [_] C.map_eval_ctx as super + + method! visit_aloan_content env lc = + match lc with + | V.AMutLoan (bid, av) -> + if bid = l then update () else super#visit_AMutLoan env bid av + | V.ASharedLoan (bids, v, av) -> + if V.BorrowId.Set.mem l bids then update () + else super#visit_ASharedLoan env bids v av + | V.AEndedMutLoan { given_back; child } -> + super#visit_AEndedMutLoan env given_back child + | V.AEndedSharedLoan (v, av) -> super#visit_AEndedSharedLoan env v av + | V.AIgnoredMutLoan (bid, av) -> super#visit_AIgnoredMutLoan env bid av + | V.AEndedIgnoredMutLoan { given_back; child } -> + super#visit_AEndedIgnoredMutLoan env given_back child + | V.AIgnoredSharedLoan av -> super#visit_AIgnoredSharedLoan env av + + method! visit_abs env abs = + if ek.enter_abs then super#visit_abs env abs else abs + (** Note that once inside the abstractions, we don't control diving + (there are no use cases requiring finer control). *) + end + in + + let ctx = obj#visit_eval_ctx () ctx in + (* Check that we updated at least one loan *) + assert !r; + ctx + +(** Lookup a borrow content from a borrow id. *) +let lookup_borrow_opt (ek : exploration_kind) (l : V.BorrowId.id) + (ctx : C.eval_ctx) : g_borrow_content option = + let obj = + object + inherit [_] C.iter_eval_ctx as super + + method! visit_borrow_content env bc = + match bc with + | V.MutBorrow (bid, mv) -> + (* Check the borrow id and control the dive *) + if bid = l then raise (FoundGBorrowContent (Concrete bc)) + else if ek.enter_mut_borrows then super#visit_MutBorrow env bid mv + else () + | V.SharedBorrow bid -> + (* Check the borrow id *) + if bid = l then raise (FoundGBorrowContent (Concrete bc)) else () + | V.InactivatedMutBorrow bid -> + (* Check the borrow id *) + if bid = l then raise (FoundGBorrowContent (Concrete bc)) else () + + method! visit_loan_content env lc = + match lc with + | V.MutLoan bid -> + (* Nothing special to do *) super#visit_MutLoan env bid + | V.SharedLoan (bids, sv) -> + (* Control the dive *) + if ek.enter_shared_loans then super#visit_SharedLoan env bids sv + else () + + method! visit_aborrow_content env bc = + match bc with + | V.AMutBorrow (bid, av) -> + if bid = l then raise (FoundGBorrowContent (Abstract bc)) + else super#visit_AMutBorrow env bid av + | V.ASharedBorrow bid -> + if bid = l then raise (FoundGBorrowContent (Abstract bc)) + else super#visit_ASharedBorrow env bid + | V.AIgnoredMutBorrow av -> super#visit_AIgnoredMutBorrow env av + | V.AProjSharedBorrow asb -> + if borrow_in_asb l asb then + raise (FoundGBorrowContent (Abstract bc)) + else () + + method! visit_abs env abs = + if ek.enter_abs then super#visit_abs env abs else () + end + in + (* We use exceptions *) + try + obj#visit_eval_ctx () ctx; + None + with FoundGBorrowContent lc -> Some lc + +(** Lookup a borrow content from a borrow id. + + Raise an exception if no loan was found +*) +let lookup_borrow (ek : exploration_kind) (l : V.BorrowId.id) (ctx : C.eval_ctx) + : g_borrow_content = + match lookup_borrow_opt ek l ctx with + | None -> failwith "Unreachable" + | Some lc -> lc + +(** Update a borrow content. + + The borrow is referred to by a borrow id. + + This is a helper function: it might break invariants. + *) +let update_borrow (ek : exploration_kind) (l : V.BorrowId.id) + (nbc : V.borrow_content) (ctx : C.eval_ctx) : C.eval_ctx = + (* We use a reference to check that we update exactly one borrow: when updating + * inside values, we check we don't update more than one borrow. Then, upon + * returning we check that we updated at least once. *) + let r = ref false in + let update () : V.borrow_content = + assert (not !r); + r := true; + nbc + in + + let obj = + object + inherit [_] C.map_eval_ctx as super + + method! visit_borrow_content env bc = + match bc with + | V.MutBorrow (bid, mv) -> + (* Check the id and control dive *) + if bid = l then update () + else if ek.enter_mut_borrows then super#visit_MutBorrow env bid mv + else V.MutBorrow (bid, mv) + | V.SharedBorrow bid -> + (* Check the id *) + if bid = l then update () else super#visit_SharedBorrow env bid + | V.InactivatedMutBorrow bid -> + (* Check the id *) + if bid = l then update () + else super#visit_InactivatedMutBorrow env bid + + method! visit_loan_content env lc = + match lc with + | V.SharedLoan (bids, sv) -> + (* Control the dive *) + if ek.enter_shared_loans then super#visit_SharedLoan env bids sv + else V.SharedLoan (bids, sv) + | V.MutLoan bid -> + (* Nothing specific to do *) + super#visit_MutLoan env bid + + method! visit_abs env abs = + if ek.enter_abs then super#visit_abs env abs else abs + end + in + + let ctx = obj#visit_eval_ctx () ctx in + (* Check that we updated at least one borrow *) + assert !r; + ctx + +(** Update an abstraction borrow content. + + The borrow is referred to by a borrow id. + + This is a helper function: it might break invariants. + *) +let update_aborrow (ek : exploration_kind) (l : V.BorrowId.id) (nv : V.avalue) + (ctx : C.eval_ctx) : C.eval_ctx = + (* We use a reference to check that we update exactly one borrow: when updating + * inside values, we check we don't update more than one borrow. Then, upon + * returning we check that we updated at least once. *) + let r = ref false in + let update () : V.avalue = + assert (not !r); + r := true; + nv + in + + let obj = + object + inherit [_] C.map_eval_ctx as super + + method! visit_ABorrow env bc = + match bc with + | V.AMutBorrow (bid, av) -> + if bid = l then update () + else V.ABorrow (super#visit_AMutBorrow env bid av) + | V.ASharedBorrow bid -> + if bid = l then update () + else V.ABorrow (super#visit_ASharedBorrow env bid) + | V.AIgnoredMutBorrow av -> + V.ABorrow (super#visit_AIgnoredMutBorrow env av) + | V.AProjSharedBorrow asb -> + if borrow_in_asb l asb then update () + else V.ABorrow (super#visit_AProjSharedBorrow env asb) + + method! visit_abs env abs = + if ek.enter_abs then super#visit_abs env abs else abs + end + in + + let ctx = obj#visit_eval_ctx () ctx in + (* Check that we updated at least one borrow *) + assert !r; + ctx + +(** Auxiliary function: see its usage in [end_borrow_get_borrow_in_value] *) +let update_outer_borrows (io : inner_outer) + (outer : V.AbstractionId.id option * borrow_ids option) (x : borrow_ids) : + V.AbstractionId.id option * borrow_ids option = + match io with + | Inner -> + (* If we can end inner borrows, we don't keep track of the outer borrows *) + outer + | Outer -> + let abs, opt = outer in + (abs, update_if_none opt x) + +(** Return the first loan we find in a value *) +let get_first_loan_in_value (v : V.typed_value) : V.loan_content option = + let obj = + object + inherit [_] V.iter_typed_value + + method! visit_loan_content _ lc = raise (FoundLoanContent lc) + end + in + (* We use exceptions *) + try + obj#visit_typed_value () v; + None + with FoundLoanContent lc -> Some lc diff --git a/src/InterpreterPaths.ml b/src/InterpreterPaths.ml index e8f5eefc..841c22cf 100644 --- a/src/InterpreterPaths.ml +++ b/src/InterpreterPaths.ml @@ -6,6 +6,7 @@ module Subst = Substitute module L = Logging module S = Synthesis open InterpreterUtils +open InterpreterBorrowsCore open InterpreterBorrows open InterpreterExpansion diff --git a/src/InterpreterProjectors.ml b/src/InterpreterProjectors.ml index c3fd0708..92ea6483 100644 --- a/src/InterpreterProjectors.ml +++ b/src/InterpreterProjectors.ml @@ -8,6 +8,7 @@ open TypesUtils open ValuesUtils open Utils open InterpreterUtils +open InterpreterBorrowsCore (** Auxiliary function. diff --git a/src/InterpreterUtils.ml b/src/InterpreterUtils.ml index be3d606c..0b7d8f21 100644 --- a/src/InterpreterUtils.ml +++ b/src/InterpreterUtils.ml @@ -29,41 +29,14 @@ let statement_to_string ctx = let same_symbolic_id (sv0 : V.symbolic_value) (sv1 : V.symbolic_value) : bool = sv0.V.sv_id = sv1.V.sv_id -(* TODO: move *) let mk_var (index : V.VarId.id) (name : string option) (var_ty : T.ety) : A.var = { A.index; name; var_ty } -(** Small helper *) +(** Small helper - TODO: move *) let mk_place_from_var_id (var_id : V.VarId.id) : E.place = { var_id; projection = [] } -(** Deconstruct a type of the form `Box` to retrieve the `T` inside *) -let ty_get_box (box_ty : T.ety) : T.ety = - match box_ty with - | T.Adt (T.Assumed T.Box, [], [ boxed_ty ]) -> boxed_ty - | _ -> failwith "Not a boxed type" - -(** Deconstruct a type of the form `&T` or `&mut T` to retrieve the `T` (and - the borrow kind, etc.) - *) -let ty_get_ref (ty : T.ety) : T.erased_region * T.ety * T.ref_kind = - match ty with - | T.Ref (r, ty, ref_kind) -> (r, ty, ref_kind) - | _ -> failwith "Not a ref type" - -let mk_ref_ty (r : 'r) (ty : 'r T.ty) (ref_kind : T.ref_kind) : 'r T.ty = - T.Ref (r, ty, ref_kind) - -(** Make a box type *) -let mk_box_ty (ty : 'r T.ty) : 'r T.ty = T.Adt (T.Assumed T.Box, [], [ ty ]) - -(** Box a value *) -let mk_box_value (v : V.typed_value) : V.typed_value = - let box_ty = mk_box_ty v.V.ty in - let box_v = V.Adt { variant_id = None; field_values = [ v ] } in - mk_typed_value box_ty box_v - (** Create a fresh symbolic proj comp *) let mk_fresh_symbolic_proj_comp (ended_regions : T.RegionId.set_t) (ty : T.rty) (ctx : C.eval_ctx) : C.eval_ctx * V.symbolic_proj_comp = @@ -125,22 +98,6 @@ let remove_borrow_from_asb (bid : V.BorrowId.id) assert (!removed = 1); asb -(* TODO: cleanup this a bit, once we have a better understanding about what we need *) -type exploration_kind = { - enter_shared_loans : bool; - enter_mut_borrows : bool; - enter_abs : bool; - (** Note that if we allow to enter abs, we don't check whether we enter - mutable/shared loans or borrows: there are no use cases requiring - a finer control. *) -} -(** This record controls how some generic helper lookup/update - functions behave, by restraining the kind of therms they can enter. -*) - -let ek_all : exploration_kind = - { enter_shared_loans = true; enter_mut_borrows = true; enter_abs = true } - (** We sometimes need to return a value whose type may vary depending on whether we find it in a "concrete" value or an abstraction (ex.: loan contents when we perform environment lookups by using borrow ids) *) @@ -244,388 +201,6 @@ let symbolic_value_id_in_ctx (sv_id : V.SymbolicValueId.id) (ctx : C.eval_ctx) : false with Found -> true -(** Lookup a loan content. - - The loan is referred to by a borrow id. - - TODO: group abs_or_var_id and g_loan_content. - *) -let lookup_loan_opt (ek : exploration_kind) (l : V.BorrowId.id) - (ctx : C.eval_ctx) : (abs_or_var_id * g_loan_content) option = - (* We store here whether we are inside an abstraction or a value - note that we - * could also track that with the environment, it would probably be more idiomatic - * and cleaner *) - let abs_or_var : abs_or_var_id option ref = ref None in - - let obj = - object - inherit [_] C.iter_eval_ctx as super - - method! visit_borrow_content env bc = - match bc with - | V.SharedBorrow bid -> - (* Nothing specific to do *) - super#visit_SharedBorrow env bid - | V.InactivatedMutBorrow bid -> - (* Nothing specific to do *) - super#visit_InactivatedMutBorrow env bid - | V.MutBorrow (bid, mv) -> - (* Control the dive *) - if ek.enter_mut_borrows then super#visit_MutBorrow env bid mv - else () - - method! visit_loan_content env lc = - match lc with - | V.SharedLoan (bids, sv) -> - (* Check if this is the loan we are looking for, and control the dive *) - if V.BorrowId.Set.mem l bids then - raise (FoundGLoanContent (Concrete lc)) - else if ek.enter_shared_loans then - super#visit_SharedLoan env bids sv - else () - | V.MutLoan bid -> - (* Check if this is the loan we are looking for *) - if bid = l then raise (FoundGLoanContent (Concrete lc)) - else super#visit_MutLoan env bid - (** We reimplement [visit_Loan] (rather than the more precise functions - [visit_SharedLoan], etc.) on purpose: as we have an exhaustive match - below, we are more resilient to definition updates (the compiler - is our friend). - *) - - method! visit_aloan_content env lc = - match lc with - | V.AMutLoan (bid, av) -> - if bid = l then raise (FoundGLoanContent (Abstract lc)) - else super#visit_AMutLoan env bid av - | V.ASharedLoan (bids, v, av) -> - if V.BorrowId.Set.mem l bids then - raise (FoundGLoanContent (Abstract lc)) - else super#visit_ASharedLoan env bids v av - | V.AEndedMutLoan { given_back; child } -> - super#visit_AEndedMutLoan env given_back child - | V.AEndedSharedLoan (v, av) -> super#visit_AEndedSharedLoan env v av - | V.AIgnoredMutLoan (bid, av) -> super#visit_AIgnoredMutLoan env bid av - | V.AEndedIgnoredMutLoan { given_back; child } -> - super#visit_AEndedIgnoredMutLoan env given_back child - | V.AIgnoredSharedLoan av -> super#visit_AIgnoredSharedLoan env av - (** Note that we don't control diving inside the abstractions: if we - allow to dive inside abstractions, we allow to go anywhere - (because there are no use cases requiring finer control) *) - - method! visit_Var env bv v = - assert (Option.is_none !abs_or_var); - abs_or_var := Some (VarId bv.C.index); - super#visit_Var env bv v; - abs_or_var := None - - method! visit_Abs env abs = - assert (Option.is_none !abs_or_var); - if ek.enter_abs then ( - abs_or_var := Some (AbsId abs.V.abs_id); - super#visit_Abs env abs) - else () - end - in - (* We use exceptions *) - try - obj#visit_eval_ctx () ctx; - None - with FoundGLoanContent lc -> ( - match !abs_or_var with - | Some abs_or_var -> Some (abs_or_var, lc) - | None -> failwith "Inconsistent state") - -(** Lookup a loan content. - - The loan is referred to by a borrow id. - Raises an exception if no loan was found. - *) -let lookup_loan (ek : exploration_kind) (l : V.BorrowId.id) (ctx : C.eval_ctx) : - abs_or_var_id * g_loan_content = - match lookup_loan_opt ek l ctx with - | None -> failwith "Unreachable" - | Some res -> res - -(** Update a loan content. - - The loan is referred to by a borrow id. - - This is a helper function: it might break invariants. - *) -let update_loan (ek : exploration_kind) (l : V.BorrowId.id) - (nlc : V.loan_content) (ctx : C.eval_ctx) : C.eval_ctx = - (* We use a reference to check that we update exactly one loan: when updating - * inside values, we check we don't update more than one loan. Then, upon - * returning we check that we updated at least once. *) - let r = ref false in - let update () : V.loan_content = - assert (not !r); - r := true; - nlc - in - - let obj = - object - inherit [_] C.map_eval_ctx as super - - method! visit_borrow_content env bc = - match bc with - | V.SharedBorrow _ | V.InactivatedMutBorrow _ -> - (* Nothing specific to do *) - super#visit_borrow_content env bc - | V.MutBorrow (bid, mv) -> - (* Control the dive into mutable borrows *) - if ek.enter_mut_borrows then super#visit_MutBorrow env bid mv - else V.MutBorrow (bid, mv) - - method! visit_loan_content env lc = - match lc with - | V.SharedLoan (bids, sv) -> - (* Shared loan: check if this is the loan we are looking for, and - control the dive. *) - if V.BorrowId.Set.mem l bids then update () - else if ek.enter_shared_loans then - super#visit_SharedLoan env bids sv - else V.SharedLoan (bids, sv) - | V.MutLoan bid -> - (* Mut loan: checks if this is the loan we are looking for *) - if bid = l then update () else super#visit_MutLoan env bid - (** We reimplement [visit_loan_content] (rather than one of the sub- - functions) on purpose: exhaustive matches are good for maintenance *) - - method! visit_abs env abs = - if ek.enter_abs then super#visit_abs env abs else abs - (** Note that once inside the abstractions, we don't control diving - (there are no use cases requiring finer control). - Also, as we give back a [loan_content] (and not an [aloan_content]) - we don't need to do reimplement the visit functions for the values - inside the abstractions (rk.: there may be "concrete" values inside - abstractions, so there is a utility in diving inside). *) - end - in - - let ctx = obj#visit_eval_ctx () ctx in - (* Check that we updated at least one loan *) - assert !r; - ctx - -(** Update a abstraction loan content. - - The loan is referred to by a borrow id. - - This is a helper function: it might break invariants. - *) -let update_aloan (ek : exploration_kind) (l : V.BorrowId.id) - (nlc : V.aloan_content) (ctx : C.eval_ctx) : C.eval_ctx = - (* We use a reference to check that we update exactly one loan: when updating - * inside values, we check we don't update more than one loan. Then, upon - * returning we check that we updated at least once. *) - let r = ref false in - let update () : V.aloan_content = - assert (not !r); - r := true; - nlc - in - - let obj = - object - inherit [_] C.map_eval_ctx as super - - method! visit_aloan_content env lc = - match lc with - | V.AMutLoan (bid, av) -> - if bid = l then update () else super#visit_AMutLoan env bid av - | V.ASharedLoan (bids, v, av) -> - if V.BorrowId.Set.mem l bids then update () - else super#visit_ASharedLoan env bids v av - | V.AEndedMutLoan { given_back; child } -> - super#visit_AEndedMutLoan env given_back child - | V.AEndedSharedLoan (v, av) -> super#visit_AEndedSharedLoan env v av - | V.AIgnoredMutLoan (bid, av) -> super#visit_AIgnoredMutLoan env bid av - | V.AEndedIgnoredMutLoan { given_back; child } -> - super#visit_AEndedIgnoredMutLoan env given_back child - | V.AIgnoredSharedLoan av -> super#visit_AIgnoredSharedLoan env av - - method! visit_abs env abs = - if ek.enter_abs then super#visit_abs env abs else abs - (** Note that once inside the abstractions, we don't control diving - (there are no use cases requiring finer control). *) - end - in - - let ctx = obj#visit_eval_ctx () ctx in - (* Check that we updated at least one loan *) - assert !r; - ctx - -(** Lookup a borrow content from a borrow id. *) -let lookup_borrow_opt (ek : exploration_kind) (l : V.BorrowId.id) - (ctx : C.eval_ctx) : g_borrow_content option = - let obj = - object - inherit [_] C.iter_eval_ctx as super - - method! visit_borrow_content env bc = - match bc with - | V.MutBorrow (bid, mv) -> - (* Check the borrow id and control the dive *) - if bid = l then raise (FoundGBorrowContent (Concrete bc)) - else if ek.enter_mut_borrows then super#visit_MutBorrow env bid mv - else () - | V.SharedBorrow bid -> - (* Check the borrow id *) - if bid = l then raise (FoundGBorrowContent (Concrete bc)) else () - | V.InactivatedMutBorrow bid -> - (* Check the borrow id *) - if bid = l then raise (FoundGBorrowContent (Concrete bc)) else () - - method! visit_loan_content env lc = - match lc with - | V.MutLoan bid -> - (* Nothing special to do *) super#visit_MutLoan env bid - | V.SharedLoan (bids, sv) -> - (* Control the dive *) - if ek.enter_shared_loans then super#visit_SharedLoan env bids sv - else () - - method! visit_aborrow_content env bc = - match bc with - | V.AMutBorrow (bid, av) -> - if bid = l then raise (FoundGBorrowContent (Abstract bc)) - else super#visit_AMutBorrow env bid av - | V.ASharedBorrow bid -> - if bid = l then raise (FoundGBorrowContent (Abstract bc)) - else super#visit_ASharedBorrow env bid - | V.AIgnoredMutBorrow av -> super#visit_AIgnoredMutBorrow env av - | V.AProjSharedBorrow asb -> - if borrow_in_asb l asb then - raise (FoundGBorrowContent (Abstract bc)) - else () - - method! visit_abs env abs = - if ek.enter_abs then super#visit_abs env abs else () - end - in - (* We use exceptions *) - try - obj#visit_eval_ctx () ctx; - None - with FoundGBorrowContent lc -> Some lc - -(** Lookup a borrow content from a borrow id. - - Raise an exception if no loan was found -*) -let lookup_borrow (ek : exploration_kind) (l : V.BorrowId.id) (ctx : C.eval_ctx) - : g_borrow_content = - match lookup_borrow_opt ek l ctx with - | None -> failwith "Unreachable" - | Some lc -> lc - -(** Update a borrow content. - - The borrow is referred to by a borrow id. - - This is a helper function: it might break invariants. - *) -let update_borrow (ek : exploration_kind) (l : V.BorrowId.id) - (nbc : V.borrow_content) (ctx : C.eval_ctx) : C.eval_ctx = - (* We use a reference to check that we update exactly one borrow: when updating - * inside values, we check we don't update more than one borrow. Then, upon - * returning we check that we updated at least once. *) - let r = ref false in - let update () : V.borrow_content = - assert (not !r); - r := true; - nbc - in - - let obj = - object - inherit [_] C.map_eval_ctx as super - - method! visit_borrow_content env bc = - match bc with - | V.MutBorrow (bid, mv) -> - (* Check the id and control dive *) - if bid = l then update () - else if ek.enter_mut_borrows then super#visit_MutBorrow env bid mv - else V.MutBorrow (bid, mv) - | V.SharedBorrow bid -> - (* Check the id *) - if bid = l then update () else super#visit_SharedBorrow env bid - | V.InactivatedMutBorrow bid -> - (* Check the id *) - if bid = l then update () - else super#visit_InactivatedMutBorrow env bid - - method! visit_loan_content env lc = - match lc with - | V.SharedLoan (bids, sv) -> - (* Control the dive *) - if ek.enter_shared_loans then super#visit_SharedLoan env bids sv - else V.SharedLoan (bids, sv) - | V.MutLoan bid -> - (* Nothing specific to do *) - super#visit_MutLoan env bid - - method! visit_abs env abs = - if ek.enter_abs then super#visit_abs env abs else abs - end - in - - let ctx = obj#visit_eval_ctx () ctx in - (* Check that we updated at least one borrow *) - assert !r; - ctx - -(** Update an abstraction borrow content. - - The borrow is referred to by a borrow id. - - This is a helper function: it might break invariants. - *) -let update_aborrow (ek : exploration_kind) (l : V.BorrowId.id) (nv : V.avalue) - (ctx : C.eval_ctx) : C.eval_ctx = - (* We use a reference to check that we update exactly one borrow: when updating - * inside values, we check we don't update more than one borrow. Then, upon - * returning we check that we updated at least once. *) - let r = ref false in - let update () : V.avalue = - assert (not !r); - r := true; - nv - in - - let obj = - object - inherit [_] C.map_eval_ctx as super - - method! visit_ABorrow env bc = - match bc with - | V.AMutBorrow (bid, av) -> - if bid = l then update () - else V.ABorrow (super#visit_AMutBorrow env bid av) - | V.ASharedBorrow bid -> - if bid = l then update () - else V.ABorrow (super#visit_ASharedBorrow env bid) - | V.AIgnoredMutBorrow av -> - V.ABorrow (super#visit_AIgnoredMutBorrow env av) - | V.AProjSharedBorrow asb -> - if borrow_in_asb l asb then update () - else V.ABorrow (super#visit_AProjSharedBorrow env asb) - - method! visit_abs env abs = - if ek.enter_abs then super#visit_abs env abs else abs - end - in - - let ctx = obj#visit_eval_ctx () ctx in - (* Check that we updated at least one borrow *) - assert !r; - ctx - (** TODO: move to InterpreterSymbolic or sth *) type symbolic_expansion = | SeConcrete of V.constant_value @@ -633,47 +208,6 @@ type symbolic_expansion = | SeMutRef of V.BorrowId.id * V.symbolic_proj_comp | SeSharedRef of V.BorrowId.set_t * V.symbolic_proj_comp -(** The following type identifies the relative position of expressions (in - particular borrows) in other expressions. - - For instance, it is used to control [end_borrow]: we usually only allow - to end "outer" borrows, unless we perform a drop. -*) -type inner_outer = Inner | Outer - -type borrow_ids = Borrows of V.BorrowId.Set.t | Borrow of V.BorrowId.id - -exception FoundBorrowIds of borrow_ids - -let update_if_none opt x = match opt with None -> Some x | _ -> opt - -(** Auxiliary function: see its usage in [end_borrow_get_borrow_in_value] *) -let update_outer_borrows (io : inner_outer) - (outer : V.AbstractionId.id option * borrow_ids option) (x : borrow_ids) : - V.AbstractionId.id option * borrow_ids option = - match io with - | Inner -> - (* If we can end inner borrows, we don't keep track of the outer borrows *) - outer - | Outer -> - let abs, opt = outer in - (abs, update_if_none opt x) - -(** Return the first loan we find in a value *) -let get_first_loan_in_value (v : V.typed_value) : V.loan_content option = - let obj = - object - inherit [_] V.iter_typed_value - - method! visit_loan_content _ lc = raise (FoundLoanContent lc) - end - in - (* We use exceptions *) - try - obj#visit_typed_value () v; - None - with FoundLoanContent lc -> Some lc - (** Check if two different projections intersect. This is necessary when giving a symbolic value to an abstraction: we need to check that the regions which are already ended inside the abstraction don't @@ -786,13 +320,6 @@ let bottom_in_avalue (v : V.typed_avalue) (_abs_regions : T.RegionId.set_t) : false with Found -> true -type outer_borrows_or_abs = - | OuterBorrows of borrow_ids - | OuterAbs of V.AbstractionId.id - -exception FoundOuter of outer_borrows_or_abs -(** Utility exception *) - (** Return true if a type is "primitively copyable". * * "primitively copyable" means that copying instances of this type doesn't diff --git a/src/Invariants.ml b/src/Invariants.ml index 364c14d0..05373d1b 100644 --- a/src/Invariants.ml +++ b/src/Invariants.ml @@ -9,6 +9,7 @@ module Subst = Substitute module A = CfimAst module L = Logging open InterpreterUtils +open InterpreterBorrowsCore let debug_invariants : bool ref = ref false diff --git a/src/TypesUtils.ml b/src/TypesUtils.ml index c1f52120..878ac989 100644 --- a/src/TypesUtils.ml +++ b/src/TypesUtils.ml @@ -23,6 +23,26 @@ let ty_is_unit (ty : 'r ty) : bool = (** The unit type *) let mk_unit_ty : ety = Adt (Tuple, [], []) +(** Deconstruct a type of the form `Box` to retrieve the `T` inside *) +let ty_get_box (box_ty : ety) : ety = + match box_ty with + | Adt (Assumed Box, [], [ boxed_ty ]) -> boxed_ty + | _ -> failwith "Not a boxed type" + +(** Deconstruct a type of the form `&T` or `&mut T` to retrieve the `T` (and + the borrow kind, etc.) + *) +let ty_get_ref (ty : ety) : erased_region * ety * ref_kind = + match ty with + | Ref (r, ty, ref_kind) -> (r, ty, ref_kind) + | _ -> failwith "Not a ref type" + +let mk_ref_ty (r : 'r) (ty : 'r ty) (ref_kind : ref_kind) : 'r ty = + Ref (r, ty, ref_kind) + +(** Make a box type *) +let mk_box_ty (ty : 'r ty) : 'r ty = Adt (Assumed Box, [], [ ty ]) + (** Check if a region is in a set of regions *) let region_in_set (r : RegionId.id region) (rset : RegionId.set_t) : bool = match r with Static -> false | Var id -> RegionId.Set.mem id rset diff --git a/src/ValuesUtils.ml b/src/ValuesUtils.ml index 488de15d..4a503a65 100644 --- a/src/ValuesUtils.ml +++ b/src/ValuesUtils.ml @@ -1,8 +1,14 @@ -module T = Types open TypesUtils +open Types open Values let mk_unit_value : typed_value = { value = Adt { variant_id = None; field_values = [] }; ty = mk_unit_ty } -let mk_typed_value (ty : T.ety) (value : value) : typed_value = { value; ty } +let mk_typed_value (ty : ety) (value : value) : typed_value = { value; ty } + +(** Box a value *) +let mk_box_value (v : typed_value) : typed_value = + let box_ty = mk_box_ty v.ty in + let box_v = Adt { variant_id = None; field_values = [ v ] } in + mk_typed_value box_ty box_v -- cgit v1.2.3 From 3cadf01e5b67af4ec91f2de3c32e119cd90c678c Mon Sep 17 00:00:00 2001 From: Son Ho Date: Thu, 6 Jan 2022 11:27:46 +0100 Subject: Move more definitions and do more cleanup --- src/InterpreterBorrows.ml | 1 + src/InterpreterExpressions.ml | 1 + src/InterpreterPaths.ml | 2 ++ src/InterpreterProjectors.ml | 7 +++++ src/InterpreterUtils.ml | 67 ------------------------------------------- src/Synthesis.ml | 2 ++ src/TypesUtils.ml | 15 ++++++++++ src/ValuesUtils.ml | 46 +++++++++++++++++++++++++++++ 8 files changed, 74 insertions(+), 67 deletions(-) (limited to 'src') diff --git a/src/InterpreterBorrows.ml b/src/InterpreterBorrows.ml index 38c79b66..ca1f87f1 100644 --- a/src/InterpreterBorrows.ml +++ b/src/InterpreterBorrows.ml @@ -4,6 +4,7 @@ module C = Contexts module Subst = Substitute module L = Logging open Utils +open ValuesUtils open InterpreterUtils open InterpreterBorrowsCore open InterpreterProjectors diff --git a/src/InterpreterExpressions.ml b/src/InterpreterExpressions.ml index b08c8749..e379eacd 100644 --- a/src/InterpreterExpressions.ml +++ b/src/InterpreterExpressions.ml @@ -6,6 +6,7 @@ open Errors module C = Contexts module Subst = Substitute module L = Logging +open TypesUtils open ValuesUtils module Inv = Invariants module S = Synthesis diff --git a/src/InterpreterPaths.ml b/src/InterpreterPaths.ml index 841c22cf..d4de318b 100644 --- a/src/InterpreterPaths.ml +++ b/src/InterpreterPaths.ml @@ -5,6 +5,8 @@ module C = Contexts module Subst = Substitute module L = Logging module S = Synthesis +open TypesUtils +open ValuesUtils open InterpreterUtils open InterpreterBorrowsCore open InterpreterBorrows diff --git a/src/InterpreterProjectors.ml b/src/InterpreterProjectors.ml index 92ea6483..105adb5a 100644 --- a/src/InterpreterProjectors.ml +++ b/src/InterpreterProjectors.ml @@ -10,6 +10,13 @@ open Utils open InterpreterUtils open InterpreterBorrowsCore +(** A symbolic expansion *) +type symbolic_expansion = + | SeConcrete of V.constant_value + | SeAdt of (T.VariantId.id option * V.symbolic_proj_comp list) + | SeMutRef of V.BorrowId.id * V.symbolic_proj_comp + | SeSharedRef of V.BorrowId.set_t * V.symbolic_proj_comp + (** Auxiliary function. Apply a proj_borrows on a shared borrow. diff --git a/src/InterpreterUtils.ml b/src/InterpreterUtils.ml index 0b7d8f21..5e0375d0 100644 --- a/src/InterpreterUtils.ml +++ b/src/InterpreterUtils.ml @@ -126,51 +126,6 @@ exception FoundGBorrowContent of g_borrow_content exception FoundGLoanContent of g_loan_content (** Utility exception *) -(** Check if a value contains a borrow *) -let borrows_in_value (v : V.typed_value) : bool = - let obj = - object - inherit [_] V.iter_typed_value - - method! visit_borrow_content _env _ = raise Found - end - in - (* We use exceptions *) - try - obj#visit_typed_value () v; - false - with Found -> true - -(** Check if a value contains inactivated mutable borrows *) -let inactivated_in_value (v : V.typed_value) : bool = - let obj = - object - inherit [_] V.iter_typed_value - - method! visit_InactivatedMutBorrow _env _ = raise Found - end - in - (* We use exceptions *) - try - obj#visit_typed_value () v; - false - with Found -> true - -(** Check if a value contains a loan *) -let loans_in_value (v : V.typed_value) : bool = - let obj = - object - inherit [_] V.iter_typed_value - - method! visit_loan_content _env _ = raise Found - end - in - (* We use exceptions *) - try - obj#visit_typed_value () v; - false - with Found -> true - let symbolic_value_id_in_ctx (sv_id : V.SymbolicValueId.id) (ctx : C.eval_ctx) : bool = let obj = @@ -201,13 +156,6 @@ let symbolic_value_id_in_ctx (sv_id : V.SymbolicValueId.id) (ctx : C.eval_ctx) : false with Found -> true -(** TODO: move to InterpreterSymbolic or sth *) -type symbolic_expansion = - | SeConcrete of V.constant_value - | SeAdt of (T.VariantId.id option * V.symbolic_proj_comp list) - | SeMutRef of V.BorrowId.id * V.symbolic_proj_comp - | SeSharedRef of V.BorrowId.set_t * V.symbolic_proj_comp - (** Check if two different projections intersect. This is necessary when giving a symbolic value to an abstraction: we need to check that the regions which are already ended inside the abstraction don't @@ -319,18 +267,3 @@ let bottom_in_avalue (v : V.typed_avalue) (_abs_regions : T.RegionId.set_t) : obj#visit_typed_avalue () v; false with Found -> true - -(** Return true if a type is "primitively copyable". - * - * "primitively copyable" means that copying instances of this type doesn't - * require calling dedicated functions defined through the Copy trait. It - * is the case for types like integers, shared borrows, etc. - *) -let rec type_is_primitively_copyable (ty : T.ety) : bool = - match ty with - | T.Adt ((T.AdtId _ | T.Assumed _), _, _) -> false - | T.Adt (T.Tuple, _, tys) -> List.for_all type_is_primitively_copyable tys - | T.TypeVar _ | T.Never | T.Str | T.Array _ | T.Slice _ -> false - | T.Bool | T.Char | T.Integer _ -> true - | T.Ref (_, _, T.Mut) -> false - | T.Ref (_, _, T.Shared) -> true diff --git a/src/Synthesis.ml b/src/Synthesis.ml index de482b18..85834e7a 100644 --- a/src/Synthesis.ml +++ b/src/Synthesis.ml @@ -6,6 +6,8 @@ module Subst = Substitute module A = CfimAst module L = Logging open InterpreterUtils +open InterpreterProjectors +(* for symbolic_expansion definition *) (* TODO: the below functions have very "rough" signatures and do nothing: I * defined them so that the places where we should update the synthesized diff --git a/src/TypesUtils.ml b/src/TypesUtils.ml index 878ac989..a658adce 100644 --- a/src/TypesUtils.ml +++ b/src/TypesUtils.ml @@ -108,3 +108,18 @@ let ty_has_regions (ty : ety) : bool = obj#visit_ty () ty; false with Found -> true + +(** Return true if a type is "primitively copyable". + * + * "primitively copyable" means that copying instances of this type doesn't + * require calling dedicated functions defined through the Copy trait. It + * is the case for types like integers, shared borrows, etc. + *) +let rec type_is_primitively_copyable (ty : ety) : bool = + match ty with + | Adt ((AdtId _ | Assumed _), _, _) -> false + | Adt (Tuple, _, tys) -> List.for_all type_is_primitively_copyable tys + | TypeVar _ | Never | Str | Array _ | Slice _ -> false + | Bool | Char | Integer _ -> true + | Ref (_, _, Mut) -> false + | Ref (_, _, Shared) -> true diff --git a/src/ValuesUtils.ml b/src/ValuesUtils.ml index 4a503a65..f4a10287 100644 --- a/src/ValuesUtils.ml +++ b/src/ValuesUtils.ml @@ -1,3 +1,4 @@ +open Utils open TypesUtils open Types open Values @@ -12,3 +13,48 @@ let mk_box_value (v : typed_value) : typed_value = let box_ty = mk_box_ty v.ty in let box_v = Adt { variant_id = None; field_values = [ v ] } in mk_typed_value box_ty box_v + +(** Check if a value contains a borrow *) +let borrows_in_value (v : typed_value) : bool = + let obj = + object + inherit [_] iter_typed_value + + method! visit_borrow_content _env _ = raise Found + end + in + (* We use exceptions *) + try + obj#visit_typed_value () v; + false + with Found -> true + +(** Check if a value contains inactivated mutable borrows *) +let inactivated_in_value (v : typed_value) : bool = + let obj = + object + inherit [_] iter_typed_value + + method! visit_InactivatedMutBorrow _env _ = raise Found + end + in + (* We use exceptions *) + try + obj#visit_typed_value () v; + false + with Found -> true + +(** Check if a value contains a loan *) +let loans_in_value (v : typed_value) : bool = + let obj = + object + inherit [_] iter_typed_value + + method! visit_loan_content _env _ = raise Found + end + in + (* We use exceptions *) + try + obj#visit_typed_value () v; + false + with Found -> true -- cgit v1.2.3 From f2fb0dc39cfa9aef2b16963d3f8a270ec45bae5e Mon Sep 17 00:00:00 2001 From: Son Ho Date: Thu, 6 Jan 2022 14:43:35 +0100 Subject: Make good progress on implementing utilities to test symbolic execution --- src/CfimAst.ml | 17 ++++- src/CfimAstUtils.ml | 5 +- src/Interpreter.ml | 173 +++++++++++++++++++++++++++++++++++++------ src/InterpreterPaths.ml | 2 +- src/InterpreterStatements.ml | 101 ++++++++++++++----------- src/InterpreterUtils.ml | 28 +++++-- src/Print.ml | 2 +- src/Utilities.ml | 16 ---- src/Utils.ml | 17 +++++ src/main.ml | 2 +- 10 files changed, 269 insertions(+), 94 deletions(-) delete mode 100644 src/Utilities.ml (limited to 'src') diff --git a/src/CfimAst.ml b/src/CfimAst.ml index a4a128c3..ac66d1a4 100644 --- a/src/CfimAst.ml +++ b/src/CfimAst.ml @@ -95,13 +95,19 @@ class ['self] iter_statement_base = method visit_assertion : 'env -> assertion -> unit = fun _ _ -> () + method visit_operand : 'env -> operand -> unit = fun _ _ -> () + method visit_call : 'env -> call -> unit = fun _ _ -> () + + method visit_integer_type : 'env -> integer_type -> unit = fun _ _ -> () + + method visit_scalar_value : 'env -> scalar_value -> unit = fun _ _ -> () end (** Ancestor for [typed_value] map visitor *) class ['self] map_statement_base = object (_self : 'self) - inherit [_] VisitorsRuntime.iter + inherit [_] VisitorsRuntime.map method visit_place : 'env -> place -> place = fun _ x -> x @@ -111,7 +117,15 @@ class ['self] map_statement_base = method visit_assertion : 'env -> assertion -> assertion = fun _ x -> x + method visit_operand : 'env -> operand -> operand = fun _ x -> x + method visit_call : 'env -> call -> call = fun _ x -> x + + method visit_integer_type : 'env -> integer_type -> integer_type = + fun _ x -> x + + method visit_scalar_value : 'env -> scalar_value -> scalar_value = + fun _ x -> x end type statement = @@ -136,7 +150,6 @@ type statement = | Sequence of statement * statement | Switch of operand * switch_targets | Loop of statement -[@@deriving show] and switch_targets = | If of statement * statement (** Gives the "if" and "else" blocks *) diff --git a/src/CfimAstUtils.ml b/src/CfimAstUtils.ml index f811475c..96410dde 100644 --- a/src/CfimAstUtils.ml +++ b/src/CfimAstUtils.ml @@ -2,7 +2,7 @@ open CfimAst open Utils (** Check if a [statement] contains loops *) -let rec statement_has_loops (st : statement) : bool = +let statement_has_loops (st : statement) : bool = let obj = object inherit [_] iter_statement @@ -14,3 +14,6 @@ let rec statement_has_loops (st : statement) : bool = obj#visit_statement () st; false with Found -> true + +(** Check if a [fun_def] contains loops *) +let fun_def_has_loops (fd : fun_def) : bool = statement_has_loops fd.body diff --git a/src/Interpreter.ml b/src/Interpreter.ml index e74aa1e7..cb42abf2 100644 --- a/src/Interpreter.ml +++ b/src/Interpreter.ml @@ -1,4 +1,9 @@ +open Errors module L = Logging +module T = Types +module A = CfimAst +open Utils +open InterpreterUtils open InterpreterExpressions open InterpreterStatements @@ -18,9 +23,94 @@ open InterpreterStatements (* TODO: remove the config parameters when they are useless *) module Test = struct + let initialize_context (type_context : C.type_context) + (fun_defs : A.fun_def list) : C.eval_ctx = + { + C.type_context; + C.fun_context = fun_defs; + C.type_vars = []; + C.env = []; + C.symbolic_counter = V.SymbolicValueId.generator_zero; + C.borrow_counter = V.BorrowId.generator_zero; + C.region_counter = T.RegionId.generator_zero; + C.abstraction_counter = V.AbstractionId.generator_zero; + } + + (** Initialize an evaluation context to execute a function. + + Introduces local variables initialized in the following manner: + - input arguments are initialized as symbolic values + - the remaining locals are initialized as ⊥ + "Dummy" abstractions are introduced for the regions present in the + function signature. + *) + let initialize_symbolic_context_for_fun (type_context : C.type_context) + (fun_defs : A.fun_def list) (fdef : A.fun_def) : C.eval_ctx = + (* The abstractions are not initialized the same way as for function + * calls: they contain *loan* projectors, because they "provide" us + * with the input values (which behave as if they had been returned + * by some function calls...). + * Also, note that we properly set the set of parents of every abstraction: + * this should not be necessary, as those abstractions should never be + * *automatically* ended (because ending some borrows requires to end + * one of them), but rather selectively ended when generating code + * for each of the backward functions. We do it only because we can + * do it, and because it gives a bit of sanity. + * *) + (* Create the context *) + let ctx = initialize_context type_context fun_defs in + (* Instantiate the signature *) + let sg = fdef.signature in + let type_params = + List.map (fun tv -> T.TypeVar tv.T.index) sg.type_params + in + let ctx, inst_sg = instantiate_fun_sig type_params sg ctx in + (* Create fresh symbolic values for the inputs *) + let ctx, input_svs = + List.fold_left_map + (fun ctx ty -> mk_fresh_symbolic_value ty ctx) + ctx inst_sg.inputs + in + (* Create the abstractions and insert them in the context *) + let create_abs (ctx : C.eval_ctx) (rg : A.abs_region_group) : C.eval_ctx = + let abs_id = rg.A.id in + let parents = + List.fold_left + (fun s pid -> V.AbstractionId.Set.add pid s) + V.AbstractionId.Set.empty rg.A.parents + in + let regions = + List.fold_left + (fun s rid -> T.RegionId.Set.add rid s) + T.RegionId.Set.empty rg.A.regions + in + (* Project over the values - we use *loan* projectors, as explained above *) + let avalues = List.map mk_aproj_loans_from_symbolic_value input_svs in + (* Create the abstraction *) + let abs = { V.abs_id; parents; regions; avalues } in + (* Insert the abstraction in the context *) + let ctx = { ctx with env = Abs abs :: ctx.env } in + (* Return *) + ctx + in + (* Split the variables between return var, inputs and remaining locals *) + let ret_var = List.hd fdef.locals in + let input_vars, local_vars = + list_split_at (List.tl fdef.locals) fdef.arg_count + in + (* Push the return variable (initialized with ⊥) *) + let ctx = C.ctx_push_uninitialized_var ctx ret_var in + (* Push the input variables (initialized with symbolic values) *) + let input_values = List.map mk_typed_value_from_symbolic_value input_svs in + let ctx = C.ctx_push_vars ctx (List.combine input_vars input_values) in + (* Push the remaining local variables (initialized with ⊥) *) + let ctx = C.ctx_push_uninitialized_vars ctx local_vars in + (* Return *) + ctx + (** Test a unit function (taking no arguments) by evaluating it in an empty - environment - *) + environment. + *) let test_unit_function (type_context : C.type_context) (fun_defs : A.fun_def list) (fid : A.FunDefId.id) : unit eval_result = (* Retrieve the function declaration *) @@ -36,20 +126,9 @@ module Test = struct assert (fdef.A.arg_count = 0); (* Create the evaluation context *) - let ctx = - { - C.type_context; - C.fun_context = fun_defs; - C.type_vars = []; - C.env = []; - C.symbolic_counter = V.SymbolicValueId.generator_zero; - C.borrow_counter = V.BorrowId.generator_zero; - C.region_counter = T.RegionId.generator_zero; - C.abstraction_counter = V.AbstractionId.generator_zero; - } - in + let ctx = initialize_context type_context fun_defs in - (* Put the (uninitialized) local variables *) + (* Insert the (uninitialized) local variables *) let ctx = C.ctx_push_uninitialized_vars ctx fdef.A.locals in (* Evaluate the function *) @@ -70,15 +149,65 @@ module Test = struct && List.length def.A.signature.inputs = 0 (** Test all the unit functions in a list of function definitions *) - let test_all_unit_functions (type_defs : T.type_def list) + let test_unit_functions (type_defs : T.type_def list) + (fun_defs : A.fun_def list) : unit = + let unit_funs = List.filter fun_def_is_unit fun_defs in + let test_unit_fun (def : A.fun_def) : unit = + let type_ctx = { C.type_defs } in + match test_unit_function type_ctx fun_defs def.A.def_id with + | Error _ -> failwith "Unit test failed (concrete execution)" + | Ok _ -> () + in + List.iter test_unit_fun unit_funs + + (** Execute the symbolic interpreter on a function. *) + let test_symbolic_function (type_context : C.type_context) + (fun_defs : A.fun_def list) (fid : A.FunDefId.id) : unit eval_result list + = + (* Retrieve the function declaration *) + let fdef = A.FunDefId.nth fun_defs fid in + + (* Debug *) + L.log#ldebug + (lazy + ("test_symbolic_function: " ^ Print.Types.name_to_string fdef.A.name)); + + (* Sanity check - *) + assert (List.length fdef.A.signature.region_params = 0); + assert (List.length fdef.A.signature.type_params = 0); + assert (fdef.A.arg_count = 0); + + (* Create the evaluation context *) + let ctx = initialize_context type_context fun_defs in + + (* Initialize the inputs as symbolic values *) + raise Unimplemented + + (* (* Initialize the remaining local variables as Bottom *) + let ctx = C.ctx_push_uninitialized_vars ctx fdef.A.locals in + + (* Evaluate the function *) + let config = { C.mode = C.ConcreteMode; C.check_invariants = true } in + match eval_function_body config ctx fdef.A.body with + | [ Ok _ ] -> Ok () + | [ Error err ] -> Error err + | _ -> + (* We execute the concrete interpreter: there shouldn't be any branching *) + failwith "Unreachable"*) + + (** Execute the symbolic interpreter on a list of functions. + + TODO: for now we ignore the functions which contain loops, because + they are not supported by the symbolic interpreter. + *) + let test_symbolic_functions (type_defs : T.type_def list) (fun_defs : A.fun_def list) : unit = + let no_loop_funs = List.filter CfimAstUtils.fun_def_has_loops fun_defs in let test_fun (def : A.fun_def) : unit = - if fun_def_is_unit def then - let type_ctx = { C.type_defs } in - match test_unit_function type_ctx fun_defs def.A.def_id with - | Error _ -> failwith "Unit test failed" - | Ok _ -> () - else () + let type_ctx = { C.type_defs } in + let res = test_symbolic_function type_ctx fun_defs def.A.def_id in + if List.for_all Result.is_ok res then () + else failwith "Unit test failed (symbolic execution)" in List.iter test_fun fun_defs end diff --git a/src/InterpreterPaths.ml b/src/InterpreterPaths.ml index d4de318b..80725bab 100644 --- a/src/InterpreterPaths.ml +++ b/src/InterpreterPaths.ml @@ -410,7 +410,7 @@ let expand_bottom_value_from_projection (config : C.config) during whose evaluation we got stuck *) let projection' = fst - (Utilities.list_split_at p.projection + (Utils.list_split_at p.projection (List.length p.projection - remaining_pes)) in let p' = { p with projection = projection' } in diff --git a/src/InterpreterStatements.ml b/src/InterpreterStatements.ml index 91035574..6b06a27f 100644 --- a/src/InterpreterStatements.ml +++ b/src/InterpreterStatements.ml @@ -421,6 +421,54 @@ let eval_non_local_function_call_concrete (config : C.config) (ctx : C.eval_ctx) (* Return *) Ok ctx) +(** Instantiate a function signature, introducing fresh abstraction ids and + region ids. This is mostly used in preparation of function calls, when + evaluating in symbolic mode of course. + + Note: there are no region parameters, because they should be erased. + *) +let instantiate_fun_sig (type_params : T.ety list) (sg : A.fun_sig) + (ctx : C.eval_ctx) : C.eval_ctx * A.inst_fun_sig = + (* Generate fresh abstraction ids and create a substitution from region + * group ids to abstraction ids *) + let ctx, rg_abs_ids_bindings = + List.fold_left_map + (fun ctx rg -> + let ctx, abs_id = C.fresh_abstraction_id ctx in + (ctx, (rg.A.id, abs_id))) + ctx sg.regions_hierarchy + in + let asubst_map : V.AbstractionId.id A.RegionGroupId.Map.t = + List.fold_left + (fun mp (rg_id, abs_id) -> A.RegionGroupId.Map.add rg_id abs_id mp) + A.RegionGroupId.Map.empty rg_abs_ids_bindings + in + let asubst (rg_id : A.RegionGroupId.id) : V.AbstractionId.id = + A.RegionGroupId.Map.find rg_id asubst_map + in + (* Generate fresh regions and their substitutions *) + let ctx, _, rsubst, _ = + Subst.fresh_regions_with_substs sg.region_params ctx + in + (* Generate the type substitution + * Note that we need the substitution to map the type variables to + * [rty] types (not [ety]). In order to do that, we convert the + * type parameters to types with regions. This is possible only + * if those types don't contain any regions. + * This is a current limitation of the analysis: there is still some + * work to do to properly handle full type parametrization. + * *) + let rtype_params = List.map ety_no_regions_to_rty type_params in + let tsubst = + Subst.make_type_subst + (List.map (fun v -> v.T.index) sg.type_params) + rtype_params + in + (* Substitute the signature *) + let inst_sig = Subst.substitute_signature asubst rsubst tsubst sg in + (* Return *) + (ctx, inst_sig) + (** Evaluate a statement *) let rec eval_statement (config : C.config) (ctx : C.eval_ctx) (st : A.statement) : (C.eval_ctx * statement_eval_res) eval_result list = @@ -661,7 +709,7 @@ and eval_local_function_call_concrete (config : C.config) (ctx : C.eval_ctx) let ctx = C.ctx_push_var ctx ret_var (C.mk_bottom ret_var.var_ty) in (* 2. Push the input values *) - let input_locals, locals = Utilities.list_split_at locals def.A.arg_count in + let input_locals, locals = Utils.list_split_at locals def.A.arg_count in let inputs = List.combine input_locals args in (* Note that this function checks that the variables and their values have the same type (this is important) *) @@ -697,43 +745,9 @@ and eval_local_function_call_symbolic (config : C.config) (ctx : C.eval_ctx) (* Retrieve the (correctly instantiated) signature *) let def = C.ctx_lookup_fun_def ctx fid in let sg = def.A.signature in - (* Generate fresh abstraction ids and create a substitution from region - * group ids to abstraction ids *) - let ctx, rg_abs_ids_bindings = - List.fold_left_map - (fun ctx rg -> - let ctx, abs_id = C.fresh_abstraction_id ctx in - (ctx, (rg.A.id, abs_id))) - ctx sg.regions_hierarchy - in - let asubst_map : V.AbstractionId.id A.RegionGroupId.Map.t = - List.fold_left - (fun mp (rg_id, abs_id) -> A.RegionGroupId.Map.add rg_id abs_id mp) - A.RegionGroupId.Map.empty rg_abs_ids_bindings - in - let asubst (rg_id : A.RegionGroupId.id) : V.AbstractionId.id = - A.RegionGroupId.Map.find rg_id asubst_map - in - (* Generate fresh regions and their substitutions *) - let ctx, _, rsubst, _ = - Subst.fresh_regions_with_substs sg.region_params ctx - in - (* Generate the type substitution - * Note that we need the substitution to map the type variables to - * [rty] types (not [ety]). In order to do that, we convert the - * type parameters to types with regions. This is possible only - * if those types don't contain any regions. - * This is a current limitation of the analysis: there is still some - * work to do to properly handle full type parametrization. - * *) - let rtype_params = List.map ety_no_regions_to_rty type_params in - let tsubst = - Subst.make_type_subst - (List.map (fun v -> v.T.index) sg.type_params) - rtype_params - in - (* Substitute the signature *) - let inst_sg = Subst.substitute_signature asubst rsubst tsubst sg in + (* Instantiate the signature and introduce fresh abstraction and region ids + * while doing so *) + let ctx, inst_sg = instantiate_fun_sig type_params sg ctx in (* Sanity check *) assert (List.length args = def.A.arg_count); (* Evaluate the function call *) @@ -755,10 +769,7 @@ and eval_function_call_symbolic_from_inst_sig (config : C.config) mk_fresh_symbolic_proj_comp T.RegionId.Set.empty ret_sv_ty ctx in let ret_value = mk_typed_value_from_proj_comp ret_spc in - let ret_av = V.ASymbolic (V.AProjLoans ret_spc.V.svalue) in - let ret_av : V.typed_avalue = - { V.value = ret_av; V.ty = ret_spc.V.svalue.V.sv_ty } - in + let ret_av = mk_aproj_loans_from_symbolic_value ret_spc.V.svalue in (* Evaluate the input operands *) let ctx, args = eval_operands config ctx args in let args_with_rtypes = List.combine args inst_sg.A.inputs in @@ -768,8 +779,8 @@ and eval_function_call_symbolic_from_inst_sig (config : C.config) (fun ((arg, rty) : V.typed_value * T.rty) -> arg.V.ty = Subst.erase_regions rty) args_with_rtypes); - (* Generate the abstractions from the region groups and add them to the context *) - let gen_abs (ctx : C.eval_ctx) (rg : A.abs_region_group) : C.eval_ctx = + (* Create the abstractions from the region groups and add them to the context *) + let create_abs (ctx : C.eval_ctx) (rg : A.abs_region_group) : C.eval_ctx = let abs_id = rg.A.id in let parents = List.fold_left @@ -797,7 +808,7 @@ and eval_function_call_symbolic_from_inst_sig (config : C.config) (* Return *) ctx in - let ctx = List.fold_left gen_abs ctx inst_sg.A.regions_hierarchy in + let ctx = List.fold_left create_abs ctx inst_sg.A.regions_hierarchy in (* Move the return value to its destination *) let ctx = assign_to_place config ctx ret_value dest in (* Synthesis *) diff --git a/src/InterpreterUtils.ml b/src/InterpreterUtils.ml index 5e0375d0..cc54cd24 100644 --- a/src/InterpreterUtils.ml +++ b/src/InterpreterUtils.ml @@ -37,11 +37,17 @@ let mk_var (index : V.VarId.id) (name : string option) (var_ty : T.ety) : A.var let mk_place_from_var_id (var_id : V.VarId.id) : E.place = { var_id; projection = [] } +(** Create a fresh symbolic value *) +let mk_fresh_symbolic_value (ty : T.rty) (ctx : C.eval_ctx) : + C.eval_ctx * V.symbolic_value = + let ctx, sv_id = C.fresh_symbolic_value_id ctx in + let svalue = { V.sv_id; V.sv_ty = ty } in + (ctx, svalue) + (** Create a fresh symbolic proj comp *) let mk_fresh_symbolic_proj_comp (ended_regions : T.RegionId.set_t) (ty : T.rty) (ctx : C.eval_ctx) : C.eval_ctx * V.symbolic_proj_comp = - let ctx, sv_id = C.fresh_symbolic_value_id ctx in - let svalue = { V.sv_id; V.sv_ty = ty } in + let ctx, svalue = mk_fresh_symbolic_value ty ctx in let sv = { V.svalue; rset_ended = ended_regions } in (ctx, sv) @@ -64,12 +70,24 @@ let mk_typed_value_from_symbolic_value (svalue : V.symbolic_value) : let spc = { V.svalue; rset_ended = T.RegionId.Set.empty } in mk_typed_value_from_proj_comp spc -let mk_aproj_loans_from_proj_comp (sv : V.symbolic_proj_comp) : V.typed_avalue = - let ty = sv.V.svalue.V.sv_ty in - let proj = V.AProjLoans sv.V.svalue in +let mk_aproj_loans_from_proj_comp (spc : V.symbolic_proj_comp) : V.typed_avalue + = + let ty = spc.V.svalue.V.sv_ty in + let proj = V.AProjLoans spc.V.svalue in let value = V.ASymbolic proj in { V.value; ty } +(** Create a Loans projector from a symbolic value. + + Initializes the set of ended regions with `empty`. + *) +let mk_aproj_loans_from_symbolic_value (svalue : V.symbolic_value) : + V.typed_avalue = + let spc = { V.svalue; rset_ended = T.RegionId.Set.empty } in + let av = V.ASymbolic (V.AProjLoans spc.V.svalue) in + let av : V.typed_avalue = { V.value = av; V.ty = svalue.V.sv_ty } in + av + (** TODO: move *) let borrow_is_asb (bid : V.BorrowId.id) (asb : V.abstract_shared_borrow) : bool = diff --git a/src/Print.ml b/src/Print.ml index 90f3946b..de1952e1 100644 --- a/src/Print.ml +++ b/src/Print.ml @@ -843,7 +843,7 @@ module CfimAst = struct (* Arguments *) let inputs = List.tl def.locals in - let inputs, _aux_locals = Utilities.list_split_at inputs def.arg_count in + let inputs, _aux_locals = Utils.list_split_at inputs def.arg_count in let args = List.combine inputs sg.inputs in let args = List.map diff --git a/src/Utilities.ml b/src/Utilities.ml deleted file mode 100644 index 6452d56f..00000000 --- a/src/Utilities.ml +++ /dev/null @@ -1,16 +0,0 @@ -(* Split a list at a given index [i] (the first list contains all the elements - up to element of index [i], not included, the second one contains the remaining - elements. Note that the first returned list has length [i]. - *) -let rec list_split_at (ls : 'a list) (i : int) = - if i < 0 then raise (Invalid_argument "list_split_at take positive integers") - else if i = 0 then ([], ls) - else - match ls with - | [] -> - raise - (Failure - "The int given to list_split_at should be <= the list's length") - | x :: ls' -> - let ls1, ls2 = list_split_at ls' (i - 1) in - (x :: ls1, ls2) diff --git a/src/Utils.ml b/src/Utils.ml index a285e869..16ee7252 100644 --- a/src/Utils.ml +++ b/src/Utils.ml @@ -1,3 +1,20 @@ +(* Split a list at a given index [i] (the first list contains all the elements + up to element of index [i], not included, the second one contains the remaining + elements. Note that the first returned list has length [i]. +*) +let rec list_split_at (ls : 'a list) (i : int) = + if i < 0 then raise (Invalid_argument "list_split_at take positive integers") + else if i = 0 then ([], ls) + else + match ls with + | [] -> + raise + (Failure + "The int given to list_split_at should be <= the list's length") + | x :: ls' -> + let ls1, ls2 = list_split_at ls' (i - 1) in + (x :: ls1, ls2) + exception Found (** Utility exception diff --git a/src/main.ml b/src/main.ml index 2d2518c7..b4537c3a 100644 --- a/src/main.ml +++ b/src/main.ml @@ -46,4 +46,4 @@ let () = log#ldebug (lazy ("\n" ^ Print.Module.module_to_string m ^ "\n")); (* Test the unit functions *) - I.Test.test_all_unit_functions m.types m.functions + I.Test.test_unit_functions m.types m.functions -- cgit v1.2.3 From ec40683d2462ae15c1d0e68dbf8c6e14825b9cef Mon Sep 17 00:00:00 2001 From: Son Ho Date: Thu, 6 Jan 2022 14:48:32 +0100 Subject: Implement tests for the symbolic interpreter --- src/Interpreter.ml | 26 ++++++++------------------ src/InterpreterStatements.ml | 2 +- src/main.ml | 7 +++++-- 3 files changed, 14 insertions(+), 21 deletions(-) (limited to 'src') diff --git a/src/Interpreter.ml b/src/Interpreter.ml index cb42abf2..6b27b180 100644 --- a/src/Interpreter.ml +++ b/src/Interpreter.ml @@ -93,6 +93,7 @@ module Test = struct (* Return *) ctx in + let ctx = List.fold_left create_abs ctx inst_sg.regions_hierarchy in (* Split the variables between return var, inputs and remaining locals *) let ret_var = List.hd fdef.locals in let input_vars, local_vars = @@ -162,8 +163,8 @@ module Test = struct (** Execute the symbolic interpreter on a function. *) let test_symbolic_function (type_context : C.type_context) - (fun_defs : A.fun_def list) (fid : A.FunDefId.id) : unit eval_result list - = + (fun_defs : A.fun_def list) (fid : A.FunDefId.id) : + C.eval_ctx eval_result list = (* Retrieve the function declaration *) let fdef = A.FunDefId.nth fun_defs fid in @@ -178,22 +179,11 @@ module Test = struct assert (fdef.A.arg_count = 0); (* Create the evaluation context *) - let ctx = initialize_context type_context fun_defs in - - (* Initialize the inputs as symbolic values *) - raise Unimplemented + let ctx = initialize_symbolic_context_for_fun type_context fun_defs fdef in - (* (* Initialize the remaining local variables as Bottom *) - let ctx = C.ctx_push_uninitialized_vars ctx fdef.A.locals in - - (* Evaluate the function *) - let config = { C.mode = C.ConcreteMode; C.check_invariants = true } in - match eval_function_body config ctx fdef.A.body with - | [ Ok _ ] -> Ok () - | [ Error err ] -> Error err - | _ -> - (* We execute the concrete interpreter: there shouldn't be any branching *) - failwith "Unreachable"*) + (* Evaluate the function *) + let config = { C.mode = C.SymbolicMode; C.check_invariants = true } in + eval_function_body config ctx fdef.A.body (** Execute the symbolic interpreter on a list of functions. @@ -209,5 +199,5 @@ module Test = struct if List.for_all Result.is_ok res then () else failwith "Unit test failed (symbolic execution)" in - List.iter test_fun fun_defs + List.iter test_fun no_loop_funs end diff --git a/src/InterpreterStatements.ml b/src/InterpreterStatements.ml index 6b06a27f..114f0daf 100644 --- a/src/InterpreterStatements.ml +++ b/src/InterpreterStatements.ml @@ -906,7 +906,7 @@ and eval_local_function_call (config : C.config) (ctx : C.eval_ctx) (** Evaluate a statement seen as a function body (auxiliary helper for [eval_statement]) *) and eval_function_body (config : C.config) (ctx : C.eval_ctx) - (body : A.statement) : (C.eval_ctx, eval_error) result list = + (body : A.statement) : C.eval_ctx eval_result list = let res = eval_statement config ctx body in let finish res = match res with diff --git a/src/main.ml b/src/main.ml index b4537c3a..63f15c85 100644 --- a/src/main.ml +++ b/src/main.ml @@ -45,5 +45,8 @@ let () = (* Print the module *) log#ldebug (lazy ("\n" ^ Print.Module.module_to_string m ^ "\n")); - (* Test the unit functions *) - I.Test.test_unit_functions m.types m.functions + (* Test the unit functions with the concrete interpreter *) + I.Test.test_unit_functions m.types m.functions; + + (* Evaluate the symbolic interpreter on the functions *) + I.Test.test_symbolic_functions m.types m.functions -- cgit v1.2.3 From 7f81192171c177b5d2b35c0bd115655c868687ea Mon Sep 17 00:00:00 2001 From: Son Ho Date: Thu, 6 Jan 2022 14:51:16 +0100 Subject: Fix minor bugs --- src/Interpreter.ml | 9 +++------ 1 file changed, 3 insertions(+), 6 deletions(-) (limited to 'src') diff --git a/src/Interpreter.ml b/src/Interpreter.ml index 6b27b180..523957af 100644 --- a/src/Interpreter.ml +++ b/src/Interpreter.ml @@ -173,11 +173,6 @@ module Test = struct (lazy ("test_symbolic_function: " ^ Print.Types.name_to_string fdef.A.name)); - (* Sanity check - *) - assert (List.length fdef.A.signature.region_params = 0); - assert (List.length fdef.A.signature.type_params = 0); - assert (fdef.A.arg_count = 0); - (* Create the evaluation context *) let ctx = initialize_symbolic_context_for_fun type_context fun_defs fdef in @@ -192,7 +187,9 @@ module Test = struct *) let test_symbolic_functions (type_defs : T.type_def list) (fun_defs : A.fun_def list) : unit = - let no_loop_funs = List.filter CfimAstUtils.fun_def_has_loops fun_defs in + let no_loop_funs = + List.filter (fun f -> not (CfimAstUtils.fun_def_has_loops f)) fun_defs + in let test_fun (def : A.fun_def) : unit = let type_ctx = { C.type_defs } in let res = test_symbolic_function type_ctx fun_defs def.A.def_id in -- cgit v1.2.3 From a263101a71d5be9d3f2a738527c2eedc850eb9ad Mon Sep 17 00:00:00 2001 From: Son Ho Date: Thu, 6 Jan 2022 15:10:41 +0100 Subject: Make minor modifications --- src/Interpreter.ml | 14 ++++++++------ src/InterpreterStatements.ml | 13 +++++++------ src/InterpreterUtils.ml | 7 +++++++ src/main.ml | 2 +- 4 files changed, 23 insertions(+), 13 deletions(-) (limited to 'src') diff --git a/src/Interpreter.ml b/src/Interpreter.ml index 523957af..c8739394 100644 --- a/src/Interpreter.ml +++ b/src/Interpreter.ml @@ -162,7 +162,7 @@ module Test = struct List.iter test_unit_fun unit_funs (** Execute the symbolic interpreter on a function. *) - let test_symbolic_function (type_context : C.type_context) + let test_function_symbolic (type_context : C.type_context) (fun_defs : A.fun_def list) (fid : A.FunDefId.id) : C.eval_ctx eval_result list = (* Retrieve the function declaration *) @@ -171,7 +171,7 @@ module Test = struct (* Debug *) L.log#ldebug (lazy - ("test_symbolic_function: " ^ Print.Types.name_to_string fdef.A.name)); + ("test_function_symbolic: " ^ Print.Types.name_to_string fdef.A.name)); (* Create the evaluation context *) let ctx = initialize_symbolic_context_for_fun type_context fun_defs fdef in @@ -185,16 +185,18 @@ module Test = struct TODO: for now we ignore the functions which contain loops, because they are not supported by the symbolic interpreter. *) - let test_symbolic_functions (type_defs : T.type_def list) + let test_functions_symbolic (type_defs : T.type_def list) (fun_defs : A.fun_def list) : unit = let no_loop_funs = List.filter (fun f -> not (CfimAstUtils.fun_def_has_loops f)) fun_defs in let test_fun (def : A.fun_def) : unit = let type_ctx = { C.type_defs } in - let res = test_symbolic_function type_ctx fun_defs def.A.def_id in - if List.for_all Result.is_ok res then () - else failwith "Unit test failed (symbolic execution)" + (* Execute the function - note that as the symbolic interpreter explores + * all the path, some executions are expected to "panic": we thus don't + * check the return value *) + let _ = test_function_symbolic type_ctx fun_defs def.A.def_id in + () in List.iter test_fun no_loop_funs end diff --git a/src/InterpreterStatements.ml b/src/InterpreterStatements.ml index 114f0daf..83d531a0 100644 --- a/src/InterpreterStatements.ml +++ b/src/InterpreterStatements.ml @@ -475,8 +475,9 @@ let rec eval_statement (config : C.config) (ctx : C.eval_ctx) (st : A.statement) (* Debugging *) L.log#ldebug (lazy - ("\n" ^ eval_ctx_to_string ctx ^ "\nAbout to evaluate statement: " - ^ statement_to_string ctx st ^ "\n")); + ("\n**About to evaluate statement**: [\n" + ^ statement_to_string_with_tab ctx st + ^ "\n]\n\n**Context**:\n" ^ eval_ctx_to_string ctx ^ "\n\n")); (* Sanity check *) if config.C.check_invariants then Inv.check_invariants ctx; (* Evaluate *) @@ -504,7 +505,7 @@ let rec eval_statement (config : C.config) (ctx : C.eval_ctx) (st : A.statement) match v.value with | Concrete (Bool b) -> if b = assertion.expected then [ Ok (ctx, Unit) ] else [ Error Panic ] - | _ -> failwith "Expected a boolean") + | _ -> failwith ("Expected a boolean, got: " ^ V.show_value v.value)) | A.Call call -> eval_function_call config ctx call | A.Panic -> [ Error Panic ] | A.Return -> [ Ok (ctx, Return) ] @@ -611,9 +612,9 @@ and eval_switch (config : C.config) (op : E.operand) (tgts : A.switch_targets) eval_statement config ctx st in (* Execute the two branches *) - List.append - (expand_and_execute see_true st1) - (expand_and_execute see_false st2) + let ctxl_true = expand_and_execute see_true st1 in + let ctxl_false = expand_and_execute see_false st2 in + List.append ctxl_true ctxl_false | _ -> failwith "Inconsistent state") | A.SwitchInt (int_ty, tgts, otherwise) -> ( match op_v.value with diff --git a/src/InterpreterUtils.ml b/src/InterpreterUtils.ml index cc54cd24..9f6cf495 100644 --- a/src/InterpreterUtils.ml +++ b/src/InterpreterUtils.ml @@ -26,6 +26,9 @@ let operand_to_string = Print.EvalCtxCfimAst.operand_to_string let statement_to_string ctx = Print.EvalCtxCfimAst.statement_to_string ctx "" " " +let statement_to_string_with_tab ctx = + Print.EvalCtxCfimAst.statement_to_string ctx " " " " + let same_symbolic_id (sv0 : V.symbolic_value) (sv1 : V.symbolic_value) : bool = sv0.V.sv_id = sv1.V.sv_id @@ -65,6 +68,10 @@ let mk_typed_value_from_proj_comp (sv : V.symbolic_proj_comp) : V.typed_value = let value = V.Symbolic sv in { V.value; ty } +(** Create a typed value from a symbolic value. + + Initializes the set of ended regions with `empty`. + *) let mk_typed_value_from_symbolic_value (svalue : V.symbolic_value) : V.typed_value = let spc = { V.svalue; rset_ended = T.RegionId.Set.empty } in diff --git a/src/main.ml b/src/main.ml index 63f15c85..e5c3c324 100644 --- a/src/main.ml +++ b/src/main.ml @@ -49,4 +49,4 @@ let () = I.Test.test_unit_functions m.types m.functions; (* Evaluate the symbolic interpreter on the functions *) - I.Test.test_symbolic_functions m.types m.functions + I.Test.test_functions_symbolic m.types m.functions -- cgit v1.2.3 From 973e14973ca857ed0b3fd69fa45901c8ae08820e Mon Sep 17 00:00:00 2001 From: Son Ho Date: Thu, 6 Jan 2022 15:31:05 +0100 Subject: Fix some issues when evaluating assertions --- src/InterpreterExpansion.ml | 2 ++ src/InterpreterStatements.ml | 54 +++++++++++++++++++++++++++++++++++++++----- src/Synthesis.ml | 6 +++++ 3 files changed, 56 insertions(+), 6 deletions(-) (limited to 'src') diff --git a/src/InterpreterExpansion.ml b/src/InterpreterExpansion.ml index 46398c84..7366a819 100644 --- a/src/InterpreterExpansion.ml +++ b/src/InterpreterExpansion.ml @@ -166,6 +166,8 @@ let replace_symbolic_values (at_most_once : bool) (** Apply a symbolic expansion to a context, by replacing the original symbolic value with its expanded value. Is valid only if the expansion is not a borrow (i.e., an adt...). + + This function does update the synthesis. *) let apply_symbolic_expansion_non_borrow (config : C.config) (original_sv : V.symbolic_value) (expansion : symbolic_expansion) diff --git a/src/InterpreterStatements.ml b/src/InterpreterStatements.ml index 83d531a0..15bfb6e7 100644 --- a/src/InterpreterStatements.ml +++ b/src/InterpreterStatements.ml @@ -38,6 +38,51 @@ let assign_to_place (config : C.config) (ctx : C.eval_ctx) (v : V.typed_value) let ctx = write_place_unwrap config Write p v ctx in ctx +(** Evaluates an assertion. + + In the case the boolean under scrutinee is symbolic, we synthesize + a call to `assert ...` then continue in the success branch (and thus + expand the boolean to `true`). + *) +let eval_assertion (config : C.config) (ctx : C.eval_ctx) + (assertion : A.assertion) : C.eval_ctx eval_result = + (* There may be a symbolic expansion, so don't fully evaluate the operand + * (if we moved the value, we can't expand it because it is hanging in + * thin air, outside of the environment... *) + let ctx, v = eval_operand_prepare config ctx assertion.cond in + assert (v.ty = T.Bool); + let symbolic_mode = config.mode = C.SymbolicMode in + (* We make a choice here: we could completely decouple the concrete and + * symbolic executions here but choose not to. In the case where we + * know the concrete value of the boolean we test, we use this value + * even if we are in symbolic mode. Note that this case should be + * extremely rare... *) + match v.value with + | Concrete (Bool b) -> + (* There won't be any symbolic expansions: fully evaluate the operand *) + let ctx, v' = eval_operand config ctx assertion.cond in + assert (v' = v); + (* Branch *) + if b = assertion.expected then Ok ctx + else ( + if symbolic_mode then S.synthesize_panic (); + Error Panic) + | Symbolic sv -> + (* We register the fact that we called an assertion (the synthesized + * code will then check that the assert succeeded) then continue + * with the succeeding branch: we thus expand the symbolic value with + * `true` *) + S.synthesize_assert v; + let see = SeConcrete (V.Bool true) in + let ctx = + apply_symbolic_expansion_non_borrow config sv.V.svalue see ctx + in + S.synthesize_symbolic_expansion_no_branching sv.V.svalue see; + (* We can finally fully evaluate the operand *) + let ctx, _ = eval_operand config ctx assertion.cond in + Ok ctx + | _ -> failwith ("Expected a boolean, got: " ^ V.show_value v.value) + (** Updates the discriminant of a value at a given place. There are two situations: @@ -500,12 +545,9 @@ let rec eval_statement (config : C.config) (ctx : C.eval_ctx) (st : A.statement) [ Ok (set_discriminant config ctx p variant_id) ] | A.Drop p -> [ Ok (drop_value config ctx p, Unit) ] | A.Assert assertion -> ( - let ctx, v = eval_operand config ctx assertion.cond in - assert (v.ty = T.Bool); - match v.value with - | Concrete (Bool b) -> - if b = assertion.expected then [ Ok (ctx, Unit) ] else [ Error Panic ] - | _ -> failwith ("Expected a boolean, got: " ^ V.show_value v.value)) + match eval_assertion config ctx assertion with + | Ok ctx -> [ Ok (ctx, Unit) ] + | Error e -> [ Error e ]) | A.Call call -> eval_function_call config ctx call | A.Panic -> [ Error Panic ] | A.Return -> [ Ok (ctx, Return) ] diff --git a/src/Synthesis.ml b/src/Synthesis.ml index 85834e7a..79fa4065 100644 --- a/src/Synthesis.ml +++ b/src/Synthesis.ml @@ -23,6 +23,8 @@ open InterpreterProjectors * `s := op1 + op2` * *) +(* TODO: error Panic *) + (** Synthesize code for a symbolic expansion which doesn't lead to branching (i.e., applied on a value which is not an enumeration with several variants). *) @@ -66,3 +68,7 @@ let synthesize_function_call (_fid : A.fun_id) (_args : V.typed_value list) (_dest : E.place) (_res : V.symbolic_value) : unit = () + +let synthesize_panic () : unit = () + +let synthesize_assert (v : V.typed_value) : unit = () -- cgit v1.2.3 From 38edb4c01773626b89ff527bf8a0e1b76bd1abc6 Mon Sep 17 00:00:00 2001 From: Son Ho Date: Thu, 6 Jan 2022 15:32:41 +0100 Subject: Make a minor modification --- src/InterpreterStatements.ml | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) (limited to 'src') diff --git a/src/InterpreterStatements.ml b/src/InterpreterStatements.ml index 15bfb6e7..5eee5296 100644 --- a/src/InterpreterStatements.ml +++ b/src/InterpreterStatements.ml @@ -549,7 +549,9 @@ let rec eval_statement (config : C.config) (ctx : C.eval_ctx) (st : A.statement) | Ok ctx -> [ Ok (ctx, Unit) ] | Error e -> [ Error e ]) | A.Call call -> eval_function_call config ctx call - | A.Panic -> [ Error Panic ] + | A.Panic -> + S.synthesize_panic (); + [ Error Panic ] | A.Return -> [ Ok (ctx, Return) ] | A.Break i -> [ Ok (ctx, Break i) ] | A.Continue i -> [ Ok (ctx, Continue i) ] -- cgit v1.2.3 From ef7141aab368f682a3846a56624f3c1b90dc445c Mon Sep 17 00:00:00 2001 From: Son Ho Date: Thu, 6 Jan 2022 15:37:55 +0100 Subject: Fix some printing issues --- src/Print.ml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) (limited to 'src') diff --git a/src/Print.ml b/src/Print.ml index de1952e1..f265cacb 100644 --- a/src/Print.ml +++ b/src/Print.ml @@ -739,7 +739,7 @@ module CfimAst = struct indent ^ "set_discriminant(" ^ place_to_string fmt p ^ ", " ^ T.VariantId.to_string variant_id ^ ")" - | A.Drop p -> "drop(" ^ place_to_string fmt p ^ ")" + | A.Drop p -> indent ^ "drop(" ^ place_to_string fmt p ^ ")" | A.Assert a -> let cond = operand_to_string fmt a.A.cond in if a.A.expected then indent ^ "assert(" ^ cond ^ ")" @@ -777,7 +777,7 @@ module CfimAst = struct | A.Nop -> indent ^ "nop" | A.Sequence (st1, st2) -> statement_to_string fmt indent indent_incr st1 - ^ "\n" + ^ ";\n" ^ statement_to_string fmt indent indent_incr st2 | A.Switch (op, tgts) -> ( let op = operand_to_string fmt op in -- cgit v1.2.3 From 12752a3e62a53c56753cb58f044cd6d277f19734 Mon Sep 17 00:00:00 2001 From: Son Ho Date: Thu, 6 Jan 2022 15:48:38 +0100 Subject: Make minor improvements to printing --- src/InterpreterUtils.ml | 2 ++ src/Invariants.ml | 5 +++++ src/Print.ml | 21 +++++++++++++-------- 3 files changed, 20 insertions(+), 8 deletions(-) (limited to 'src') diff --git a/src/InterpreterUtils.ml b/src/InterpreterUtils.ml index 9f6cf495..f0e3d420 100644 --- a/src/InterpreterUtils.ml +++ b/src/InterpreterUtils.ml @@ -17,6 +17,8 @@ let eval_ctx_to_string = Print.Contexts.eval_ctx_to_string let ety_to_string = Print.EvalCtxCfimAst.ety_to_string +let rty_to_string = Print.EvalCtxCfimAst.rty_to_string + let typed_value_to_string = Print.EvalCtxCfimAst.typed_value_to_string let place_to_string = Print.EvalCtxCfimAst.place_to_string diff --git a/src/Invariants.ml b/src/Invariants.ml index 05373d1b..be3260be 100644 --- a/src/Invariants.ml +++ b/src/Invariants.ml @@ -496,6 +496,11 @@ let check_typing_invariant (ctx : C.eval_ctx) : unit = match lc with | V.AMutLoan (bid, child_av) | V.AIgnoredMutLoan (bid, child_av) -> ( + L.log#ldebug + (lazy + ("- child_av.ty: " + ^ rty_to_string ctx child_av.V.ty + ^ "\n- aty: " ^ rty_to_string ctx aty)); assert (child_av.V.ty = aty); (* Lookup the borrowed value to check it has the proper type *) let glc = lookup_borrow ek_all bid ctx in diff --git a/src/Print.ml b/src/Print.ml index f265cacb..e751d0a3 100644 --- a/src/Print.ml +++ b/src/Print.ml @@ -419,18 +419,20 @@ module Values = struct ^ abstract_shared_borrows_to_string fmt sb ^ ")" - let abs_to_string (fmt : value_formatter) (abs : V.abs) : string = + let abs_to_string (fmt : value_formatter) (indent : string) + (indent_incr : string) (abs : V.abs) : string = + let indent2 = indent ^ indent_incr in let avs = - List.map (fun av -> " " ^ typed_avalue_to_string fmt av) abs.avalues + List.map (fun av -> indent2 ^ typed_avalue_to_string fmt av) abs.avalues in let avs = String.concat ",\n" avs in - "abs@" + indent ^ "abs@" ^ V.AbstractionId.to_string abs.abs_id ^ "{parents=" ^ V.AbstractionId.set_to_string abs.parents ^ "}" ^ "{regions=" ^ T.RegionId.set_to_string abs.regions - ^ "}" ^ " {\n" ^ avs ^ "\n}" + ^ "}" ^ " {\n" ^ avs ^ "\n" ^ indent ^ "}" end module PV = Values (* local module *) @@ -442,17 +444,20 @@ module Contexts = struct | None -> PV.var_id_to_string bv.index | Some name -> name - let env_elem_to_string (fmt : PV.value_formatter) (ev : C.env_elem) : string = + let env_elem_to_string (fmt : PV.value_formatter) (indent : string) + (indent_incr : string) (ev : C.env_elem) : string = match ev with | Var (var, tv) -> - binder_to_string var ^ " -> " ^ PV.typed_value_to_string fmt tv ^ " ;" - | Abs abs -> PV.abs_to_string fmt abs + indent ^ binder_to_string var ^ " -> " + ^ PV.typed_value_to_string fmt tv + ^ " ;" + | Abs abs -> PV.abs_to_string fmt indent indent_incr abs | Frame -> failwith "Can't print a Frame element" let env_to_string (fmt : PV.value_formatter) (env : C.env) : string = "{\n" ^ String.concat "\n" - (List.map (fun ev -> " " ^ env_elem_to_string fmt ev) env) + (List.map (fun ev -> env_elem_to_string fmt " " " " ev) env) ^ "\n}" type ctx_formatter = PV.value_formatter -- cgit v1.2.3 From 407474a35b7dd80116c8d358873d25e1a9b49048 Mon Sep 17 00:00:00 2001 From: Son Ho Date: Thu, 6 Jan 2022 16:18:40 +0100 Subject: Fix some bugs --- src/InterpreterBorrowsCore.ml | 3 ++- src/InterpreterProjectors.ml | 4 ++++ src/InterpreterUtils.ml | 2 ++ src/Invariants.ml | 36 ++++++++++++++++++++++++------------ src/Print.ml | 4 ++++ src/TypesUtils.ml | 2 +- src/Values.ml | 6 +++++- 7 files changed, 42 insertions(+), 15 deletions(-) (limited to 'src') diff --git a/src/InterpreterBorrowsCore.ml b/src/InterpreterBorrowsCore.ml index ccc259f5..6e09c90c 100644 --- a/src/InterpreterBorrowsCore.ml +++ b/src/InterpreterBorrowsCore.ml @@ -128,7 +128,8 @@ let lookup_loan_opt (ek : exploration_kind) (l : V.BorrowId.id) assert (Option.is_none !abs_or_var); if ek.enter_abs then ( abs_or_var := Some (AbsId abs.V.abs_id); - super#visit_Abs env abs) + super#visit_Abs env abs; + abs_or_var := None) else () end in diff --git a/src/InterpreterProjectors.ml b/src/InterpreterProjectors.ml index 105adb5a..dfc821de 100644 --- a/src/InterpreterProjectors.ml +++ b/src/InterpreterProjectors.ml @@ -275,6 +275,8 @@ let apply_proj_loans_on_symbolic_expansion (regions : T.RegionId.set_t) in (V.AAdt { V.variant_id; field_values }, original_sv_ty) | SeMutRef (bid, spc), T.Ref (r, ref_ty, T.Mut) -> + (* Sanity check *) + assert (spc.V.svalue.V.sv_ty = ref_ty); (* Apply the projector to the borrowed value *) let child_av = mk_aproj_loans_from_proj_comp spc in (* Check if the region is in the set of projected regions (note that @@ -286,6 +288,8 @@ let apply_proj_loans_on_symbolic_expansion (regions : T.RegionId.set_t) (* Not in the set: ignore *) (V.ALoan (V.AIgnoredMutLoan (bid, child_av)), ref_ty) | SeSharedRef (bids, spc), T.Ref (r, ref_ty, T.Shared) -> + (* Sanity check *) + assert (spc.V.svalue.V.sv_ty = ref_ty); (* Apply the projector to the borrowed value *) let child_av = mk_aproj_loans_from_proj_comp spc in (* Check if the region is in the set of projected regions (note that diff --git a/src/InterpreterUtils.ml b/src/InterpreterUtils.ml index f0e3d420..458c11b4 100644 --- a/src/InterpreterUtils.ml +++ b/src/InterpreterUtils.ml @@ -21,6 +21,8 @@ let rty_to_string = Print.EvalCtxCfimAst.rty_to_string let typed_value_to_string = Print.EvalCtxCfimAst.typed_value_to_string +let typed_avalue_to_string = Print.EvalCtxCfimAst.typed_avalue_to_string + let place_to_string = Print.EvalCtxCfimAst.place_to_string let operand_to_string = Print.EvalCtxCfimAst.operand_to_string diff --git a/src/Invariants.ml b/src/Invariants.ml index be3260be..b723d861 100644 --- a/src/Invariants.ml +++ b/src/Invariants.ml @@ -8,6 +8,7 @@ module C = Contexts module Subst = Substitute module A = CfimAst module L = Logging +open TypesUtils open InterpreterUtils open InterpreterBorrowsCore @@ -341,6 +342,18 @@ let check_constant_value_type (cv : V.constant_value) (ty : T.ety) : unit = | _ -> failwith "Erroneous typing" let check_typing_invariant (ctx : C.eval_ctx) : unit = + (* TODO: the type of aloans doens't make sense: they have a type + * of the shape `& (mut) T` where they should have type `T`... + * This messes a bit the type invariant checks when checking the + * children. In order to isolate the problem (for future modifications) + * we introduce function, so that we can easily spot all the involved + * places. + * *) + let aloan_get_expected_child_type (ty : 'r T.ty) : 'r T.ty = + let _, ty, _ = ty_get_ref ty in + ty + in + let visitor = object inherit [_] C.iter_eval_ctx as super @@ -496,31 +509,30 @@ let check_typing_invariant (ctx : C.eval_ctx) : unit = match lc with | V.AMutLoan (bid, child_av) | V.AIgnoredMutLoan (bid, child_av) -> ( - L.log#ldebug - (lazy - ("- child_av.ty: " - ^ rty_to_string ctx child_av.V.ty - ^ "\n- aty: " ^ rty_to_string ctx aty)); - assert (child_av.V.ty = aty); + let borrowed_aty = aloan_get_expected_child_type aty in + assert (child_av.V.ty = borrowed_aty); (* Lookup the borrowed value to check it has the proper type *) let glc = lookup_borrow ek_all bid ctx in match glc with | Concrete (V.MutBorrow (_, bv)) -> - assert (bv.V.ty = Subst.erase_regions aty) + assert (bv.V.ty = Subst.erase_regions borrowed_aty) | Abstract (V.AMutBorrow (_, sv)) -> assert ( - Subst.erase_regions sv.V.ty = Subst.erase_regions aty) + Subst.erase_regions sv.V.ty + = Subst.erase_regions borrowed_aty) | _ -> failwith "Inconsistent context") | V.ASharedLoan (_, sv, child_av) | V.AEndedSharedLoan (sv, child_av) -> let ty = Subst.erase_regions aty in assert (sv.V.ty = ty); - assert (child_av.V.ty = aty) + (* TODO: the type of aloans doesn't make sense, see above *) + assert (child_av.V.ty = aloan_get_expected_child_type aty) | V.AEndedMutLoan { given_back; child } | V.AEndedIgnoredMutLoan { given_back; child } -> - assert (given_back.V.ty = aty); - assert (child.V.ty = aty) - | V.AIgnoredSharedLoan child_av -> assert (child_av.V.ty = aty)) + assert (given_back.V.ty = aloan_get_expected_child_type aty); + assert (child.V.ty = aloan_get_expected_child_type aty) + | V.AIgnoredSharedLoan child_av -> + assert (child_av.V.ty = aloan_get_expected_child_type aty)) | V.ASymbolic aproj, ty -> let ty1 = Subst.erase_regions ty in let ty2 = diff --git a/src/Print.ml b/src/Print.ml index e751d0a3..0b436f1a 100644 --- a/src/Print.ml +++ b/src/Print.ml @@ -981,6 +981,10 @@ module EvalCtxCfimAst = struct let fmt = PC.eval_ctx_to_ctx_formatter ctx in PV.typed_value_to_string fmt v + let typed_avalue_to_string (ctx : C.eval_ctx) (v : V.typed_avalue) : string = + let fmt = PC.eval_ctx_to_ctx_formatter ctx in + PV.typed_avalue_to_string fmt v + let place_to_string (ctx : C.eval_ctx) (op : E.place) : string = let fmt = PA.eval_ctx_to_ast_formatter ctx in PA.place_to_string fmt op diff --git a/src/TypesUtils.ml b/src/TypesUtils.ml index a658adce..04a579bf 100644 --- a/src/TypesUtils.ml +++ b/src/TypesUtils.ml @@ -32,7 +32,7 @@ let ty_get_box (box_ty : ety) : ety = (** Deconstruct a type of the form `&T` or `&mut T` to retrieve the `T` (and the borrow kind, etc.) *) -let ty_get_ref (ty : ety) : erased_region * ety * ref_kind = +let ty_get_ref (ty : 'r ty) : 'r * 'r ty * ref_kind = match ty with | Ref (r, ty, ref_kind) -> (r, ty, ref_kind) | _ -> failwith "Not a ref type" diff --git a/src/Values.ml b/src/Values.ml index ac4145eb..47bdda23 100644 --- a/src/Values.ml +++ b/src/Values.ml @@ -518,7 +518,11 @@ and aborrow_content = *) (* TODO: we may want to merge this with typed_value - would prevent some issues - when accessing fields... *) + when accessing fields.... + + TODO: the type of avalues doesn't make sense for loan avalues: they currently + are typed as `& (mut) T` instead of `T`... +*) and typed_avalue = { value : avalue; ty : rty } [@@deriving show, -- cgit v1.2.3 From b83b928109b528c02e16df099c6f9b132e920b12 Mon Sep 17 00:00:00 2001 From: Son Ho Date: Thu, 6 Jan 2022 16:24:40 +0100 Subject: Fix more bugs --- src/InterpreterBorrows.ml | 10 ++++++++-- src/Invariants.ml | 11 ++++++----- 2 files changed, 14 insertions(+), 7 deletions(-) (limited to 'src') diff --git a/src/InterpreterBorrows.ml b/src/InterpreterBorrows.ml index ca1f87f1..fbd958ef 100644 --- a/src/InterpreterBorrows.ml +++ b/src/InterpreterBorrows.ml @@ -5,6 +5,7 @@ module Subst = Substitute module L = Logging open Utils open ValuesUtils +open TypesUtils open InterpreterUtils open InterpreterBorrowsCore open InterpreterProjectors @@ -265,6 +266,11 @@ let give_back_value (config : C.config) (bid : V.BorrowId.id) | None -> failwith "Unreachable" | Some abs -> abs.V.regions in + (* Rk.: there is a small issue with the types of the aloan values *) + let borrowed_value_aty = + let _, ty, _ = ty_get_ref ty in + ty + in match lc with | V.AMutLoan (bid', child) -> if bid' = bid then ( @@ -276,7 +282,7 @@ let give_back_value (config : C.config) (bid : V.BorrowId.id) (* Apply the projection *) let given_back = apply_proj_borrows check_symbolic_no_ended ctx fresh_reborrow - regions nv ty + regions nv borrowed_value_aty in (* Return the new value *) V.ALoan (V.AEndedMutLoan { given_back; child })) @@ -302,7 +308,7 @@ let give_back_value (config : C.config) (bid : V.BorrowId.id) * (i.e., we don't call [set_replaced]) *) let given_back = apply_proj_borrows check_symbolic_no_ended ctx fresh_reborrow - regions nv ty + regions nv borrowed_value_aty in V.ALoan (V.AEndedIgnoredMutLoan { given_back; child }) else V.ALoan (super#visit_AIgnoredMutLoan opt_abs bid' child) diff --git a/src/Invariants.ml b/src/Invariants.ml index b723d861..11b00381 100644 --- a/src/Invariants.ml +++ b/src/Invariants.ml @@ -523,14 +523,15 @@ let check_typing_invariant (ctx : C.eval_ctx) : unit = | _ -> failwith "Inconsistent context") | V.ASharedLoan (_, sv, child_av) | V.AEndedSharedLoan (sv, child_av) -> - let ty = Subst.erase_regions aty in - assert (sv.V.ty = ty); + let borrowed_aty = aloan_get_expected_child_type aty in + assert (sv.V.ty = Subst.erase_regions borrowed_aty); (* TODO: the type of aloans doesn't make sense, see above *) - assert (child_av.V.ty = aloan_get_expected_child_type aty) + assert (child_av.V.ty = borrowed_aty) | V.AEndedMutLoan { given_back; child } | V.AEndedIgnoredMutLoan { given_back; child } -> - assert (given_back.V.ty = aloan_get_expected_child_type aty); - assert (child.V.ty = aloan_get_expected_child_type aty) + let borrowed_aty = aloan_get_expected_child_type aty in + assert (given_back.V.ty = borrowed_aty); + assert (child.V.ty = borrowed_aty) | V.AIgnoredSharedLoan child_av -> assert (child_av.V.ty = aloan_get_expected_child_type aty)) | V.ASymbolic aproj, ty -> -- cgit v1.2.3 From 0d330faa8a71712c8d7242d49c74dfb209092d81 Mon Sep 17 00:00:00 2001 From: Son Ho Date: Thu, 6 Jan 2022 16:28:06 +0100 Subject: Fix another bug --- src/Interpreter.ml | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) (limited to 'src') diff --git a/src/Interpreter.ml b/src/Interpreter.ml index c8739394..384e0a11 100644 --- a/src/Interpreter.ml +++ b/src/Interpreter.ml @@ -24,11 +24,11 @@ open InterpreterStatements module Test = struct let initialize_context (type_context : C.type_context) - (fun_defs : A.fun_def list) : C.eval_ctx = + (fun_defs : A.fun_def list) (type_vars : T.type_var list) : C.eval_ctx = { C.type_context; C.fun_context = fun_defs; - C.type_vars = []; + C.type_vars; C.env = []; C.symbolic_counter = V.SymbolicValueId.generator_zero; C.borrow_counter = V.BorrowId.generator_zero; @@ -57,10 +57,10 @@ module Test = struct * for each of the backward functions. We do it only because we can * do it, and because it gives a bit of sanity. * *) + let sg = fdef.signature in (* Create the context *) - let ctx = initialize_context type_context fun_defs in + let ctx = initialize_context type_context fun_defs sg.type_params in (* Instantiate the signature *) - let sg = fdef.signature in let type_params = List.map (fun tv -> T.TypeVar tv.T.index) sg.type_params in @@ -127,7 +127,7 @@ module Test = struct assert (fdef.A.arg_count = 0); (* Create the evaluation context *) - let ctx = initialize_context type_context fun_defs in + let ctx = initialize_context type_context fun_defs [] in (* Insert the (uninitialized) local variables *) let ctx = C.ctx_push_uninitialized_vars ctx fdef.A.locals in -- cgit v1.2.3 From 808f21c06314ccbbe2a61835899c943b532c9783 Mon Sep 17 00:00:00 2001 From: Son Ho Date: Thu, 6 Jan 2022 16:58:46 +0100 Subject: Implement a small improvement for apply_reborrows --- src/InterpreterProjectors.ml | 13 ++++++++++--- 1 file changed, 10 insertions(+), 3 deletions(-) (limited to 'src') diff --git a/src/InterpreterProjectors.ml b/src/InterpreterProjectors.ml index dfc821de..ada1a89a 100644 --- a/src/InterpreterProjectors.ml +++ b/src/InterpreterProjectors.ml @@ -430,13 +430,20 @@ let apply_reborrows (reborrows : (V.BorrowId.id * V.BorrowId.id) list) functions) on purpose: exhaustive matches are good for maintenance *) method! visit_aloan_content env lc = - (* TODO: ashared_loan (amut_loan ) case *) match lc with - | V.ASharedLoan (bids, v, av) -> + | V.ASharedLoan (bids, sv, av) -> (* Insert the reborrows *) let bids = insert_reborrows bids in + (* Similarly to the non-abstraction case: check if the shared + * value is a mutable borrow, to eventually insert more reborrows *) (* Update and explore *) - super#visit_ASharedLoan env bids v av + let bids = + match get_borrow_in_mut_borrow sv with + | None -> bids + | Some bid -> insert_reborrows_for_bid bids bid + in + (* Update and explore *) + super#visit_ASharedLoan env bids sv av | V.AIgnoredSharedLoan _ | V.AMutLoan (_, _) | V.AEndedMutLoan { given_back = _; child = _ } -- cgit v1.2.3 From 7137e0733650e0ce37eff4ff805c95543f2c1161 Mon Sep 17 00:00:00 2001 From: Son Ho Date: Thu, 6 Jan 2022 17:44:17 +0100 Subject: Remove the symbolic_proj_comp def and make the set of ended regions a field in the eval_ctx struct --- src/Contexts.ml | 1 + src/Interpreter.ml | 1 + src/InterpreterBorrows.ml | 80 +++++++------------------------------------ src/InterpreterExpansion.ml | 77 +++++++++++++++++------------------------ src/InterpreterExpressions.ml | 6 ++-- src/InterpreterPaths.ml | 5 ++- src/InterpreterProjectors.ml | 33 +++++++++--------- src/InterpreterStatements.ml | 29 ++++++---------- src/InterpreterUtils.ml | 78 ++++++++++++----------------------------- src/Invariants.ml | 4 +-- src/Print.ml | 12 +++---- src/Values.ml | 45 ++++++------------------ 12 files changed, 116 insertions(+), 255 deletions(-) (limited to 'src') diff --git a/src/Contexts.ml b/src/Contexts.ml index 89056680..5225645c 100644 --- a/src/Contexts.ml +++ b/src/Contexts.ml @@ -67,6 +67,7 @@ type eval_ctx = { fun_context : fun_def list; type_vars : type_var list; env : env; + ended_regions : RegionId.set_t; symbolic_counter : SymbolicValueId.generator; (* TODO: make this global? *) borrow_counter : BorrowId.generator; diff --git a/src/Interpreter.ml b/src/Interpreter.ml index 384e0a11..54911d85 100644 --- a/src/Interpreter.ml +++ b/src/Interpreter.ml @@ -30,6 +30,7 @@ module Test = struct C.fun_context = fun_defs; C.type_vars; C.env = []; + C.ended_regions = T.RegionId.Set.empty; C.symbolic_counter = V.SymbolicValueId.generator_zero; C.borrow_counter = V.BorrowId.generator_zero; C.region_counter = T.RegionId.generator_zero; diff --git a/src/InterpreterBorrows.ml b/src/InterpreterBorrows.ml index fbd958ef..3cfa78e0 100644 --- a/src/InterpreterBorrows.ml +++ b/src/InterpreterBorrows.ml @@ -626,13 +626,7 @@ let convert_avalue_to_value (av : V.typed_avalue) (ctx : C.eval_ctx) : (* Generate the fresh a symbolic value *) let ctx, sv_id = C.fresh_symbolic_value_id ctx in let svalue : V.symbolic_value = { V.sv_id; sv_ty = av.V.ty } in - let value : V.symbolic_proj_comp = - (* Note that the set of ended regions is empty: we shouldn't have to take - * into account any ended regions at this point, otherwise we would be in - * the first case where we should return ⊥ *) - { V.svalue; V.rset_ended = T.RegionId.Set.empty } - in - let value = V.Symbolic value in + let value = V.Symbolic svalue in (ctx, { V.value; V.ty }) (** End a borrow identified by its borrow id in a context @@ -759,8 +753,15 @@ and end_abstraction (config : C.config) (abs_id : V.AbstractionId.id) let ctx = end_abstraction_loans config abs_id ctx in (* End the abstraction itself by redistributing the borrows it contains *) let ctx = end_abstraction_borrows config abs_id ctx in - (* End the regions owned by the abstraction *) - let ctx = end_abstraction_regions config abs_id ctx in + (* End the regions owned by the abstraction - note that we don't need to + * relookup the abstraction: the set of regions in an abstraction never + * changes... *) + let ctx = + { + ctx with + ended_regions = T.RegionId.Set.union ctx.ended_regions abs.V.regions; + } + in (* Remove all the references to the id of the current abstraction, and remove * the abstraction itself *) end_abstraction_remove_from_context config abs_id ctx @@ -911,63 +912,6 @@ and end_abstraction_borrows (config : C.config) (abs_id : V.AbstractionId.id) (* Reexplore *) end_abstraction_borrows config abs_id ctx -(** Update the symbolic values in a context to register the regions in the - abstraction we are ending as already ended. - Note that this function also checks that no symbolic value in an abstraction - contains regions which we are ending. - Of course, we ignore the abstraction we are currently ending... - *) -and end_abstraction_regions (_config : C.config) (abs_id : V.AbstractionId.id) - (ctx : C.eval_ctx) : C.eval_ctx = - (* Lookup the abstraction to retrieve the set of owned regions *) - let abs = C.ctx_lookup_abs ctx abs_id in - let ended_regions = abs.V.regions in - (* Update all the symbolic values in the context *) - let obj = - object - inherit [_] C.map_eval_ctx as super - - method! visit_Symbolic _ sproj = - let sproj = - { - sproj with - V.rset_ended = T.RegionId.Set.union sproj.V.rset_ended ended_regions; - } - in - V.Symbolic sproj - - method! visit_aproj (abs_regions : T.RegionId.set_t option) aproj = - (* Sanity check *) - (match aproj with - | V.AProjLoans _ -> () - | V.AProjBorrows (sv, ty) -> ( - match abs_regions with - | None -> failwith "Unexpected" - | Some abs_regions -> - assert ( - not - (projections_intersect sv.V.sv_ty ended_regions ty - abs_regions)))); - (* Return - nothing to update *) - aproj - - method! visit_abs (regions : T.RegionId.set_t option) abs = - if abs.V.abs_id = abs_id then abs - else ( - assert (Option.is_none regions); - (* Check that we don't project over already ended regions *) - assert (T.RegionId.Set.disjoint ended_regions abs.V.regions); - (* Remember the set of regions owned by the abstraction *) - let regions = Some abs.V.regions in - super#visit_abs regions abs) - (** Whenever we dive in an abstraction, we need to keep track of the - set of regions owned by the abstraction. - Also: we don't dive in the abstraction we are currently ending... *) - end - in - (* Update the context *) - obj#visit_eval_ctx None ctx - (** Remove an abstraction from the context, as well as all its references *) and end_abstraction_remove_from_context (_config : C.config) (abs_id : V.AbstractionId.id) (ctx : C.eval_ctx) : C.eval_ctx = @@ -1022,7 +966,7 @@ let promote_shared_loan_to_mut_loan (l : V.BorrowId.id) (ctx : C.eval_ctx) : to do a sanity check. *) assert (not (loans_in_value sv)); (* Check there isn't [Bottom] (this is actually an invariant *) - assert (not (bottom_in_value sv)); + assert (not (bottom_in_value ctx.ended_regions sv)); (* Check there aren't inactivated borrows *) assert (not (inactivated_in_value sv)); (* Update the loan content *) @@ -1094,7 +1038,7 @@ let rec activate_inactivated_mut_borrow (config : C.config) (io : inner_outer) ("activate_inactivated_mut_borrow: resulting value:\n" ^ V.show_typed_value sv)); assert (not (loans_in_value sv)); - assert (not (bottom_in_value sv)); + assert (not (bottom_in_value ctx.ended_regions sv)); assert (not (inactivated_in_value sv)); (* End the borrows which borrow from the value, at the exception of the borrow we want to promote *) diff --git a/src/InterpreterExpansion.ml b/src/InterpreterExpansion.ml index 7366a819..24ec018e 100644 --- a/src/InterpreterExpansion.ml +++ b/src/InterpreterExpansion.ml @@ -152,7 +152,7 @@ let replace_symbolic_values (at_most_once : bool) inherit [_] C.map_eval_ctx as super method! visit_Symbolic env spc = - if same_symbolic_id spc.V.svalue original_sv then replace () + if same_symbolic_id spc original_sv then replace () else super#visit_Symbolic env spc end in @@ -190,9 +190,9 @@ let apply_symbolic_expansion_non_borrow (config : C.config) doesn't allow the expansion of enumerations *containing several variants*. *) let compute_expanded_symbolic_adt_value (expand_enumerations : bool) - (ended_regions : T.RegionId.set_t) (def_id : T.TypeDefId.id) - (regions : T.RegionId.id T.region list) (types : T.rty list) - (ctx : C.eval_ctx) : (C.eval_ctx * symbolic_expansion) list = + (def_id : T.TypeDefId.id) (regions : T.RegionId.id T.region list) + (types : T.rty list) (ctx : C.eval_ctx) : + (C.eval_ctx * symbolic_expansion) list = (* Lookup the definition and check if it is an enumeration with several * variants *) let def = C.ctx_lookup_type_def ctx def_id in @@ -210,8 +210,7 @@ let compute_expanded_symbolic_adt_value (expand_enumerations : bool) C.eval_ctx * symbolic_expansion = let ctx, field_values = List.fold_left_map - (fun ctx (ty : T.rty) -> - mk_fresh_symbolic_proj_comp ended_regions ty ctx) + (fun ctx (ty : T.rty) -> mk_fresh_symbolic_value ty ctx) ctx field_types in let see = SeAdt (variant_id, field_values) in @@ -220,32 +219,29 @@ let compute_expanded_symbolic_adt_value (expand_enumerations : bool) (* Initialize all the expanded values of all the variants *) List.map (initialize ctx) variants_fields_types -let compute_expanded_symbolic_tuple_value (ended_regions : T.RegionId.set_t) - (field_types : T.rty list) (ctx : C.eval_ctx) : - C.eval_ctx * symbolic_expansion = +let compute_expanded_symbolic_tuple_value (field_types : T.rty list) + (ctx : C.eval_ctx) : C.eval_ctx * symbolic_expansion = (* Generate the field values *) let ctx, field_values = List.fold_left_map - (fun ctx sv_ty -> mk_fresh_symbolic_proj_comp ended_regions sv_ty ctx) + (fun ctx sv_ty -> mk_fresh_symbolic_value sv_ty ctx) ctx field_types in let variant_id = None in let see = SeAdt (variant_id, field_values) in (ctx, see) -let compute_expanded_symbolic_box_value (ended_regions : T.RegionId.set_t) - (boxed_ty : T.rty) (ctx : C.eval_ctx) : C.eval_ctx * symbolic_expansion = +let compute_expanded_symbolic_box_value (boxed_ty : T.rty) (ctx : C.eval_ctx) : + C.eval_ctx * symbolic_expansion = (* Introduce a fresh symbolic value *) - let ctx, boxed_value = - mk_fresh_symbolic_proj_comp ended_regions boxed_ty ctx - in + let ctx, boxed_value = mk_fresh_symbolic_value boxed_ty ctx in let see = SeAdt (None, [ boxed_value ]) in (ctx, see) let expand_symbolic_value_shared_borrow (config : C.config) - (original_sv : V.symbolic_value) (ended_regions : T.RegionId.set_t) - (ref_ty : T.rty) (ctx : C.eval_ctx) : C.eval_ctx = - (* First, replace the projectors on borrows (AProjBorrow and proj_comp) + (original_sv : V.symbolic_value) (ref_ty : T.rty) (ctx : C.eval_ctx) : + C.eval_ctx = + (* First, replace the projectors on borrows. * The important point is that the symbolic value to expand may appear * several times, if it has been copied. In this case, we need to introduce * one fresh borrow id per instance. @@ -285,7 +281,7 @@ let expand_symbolic_value_shared_borrow (config : C.config) inherit [_] C.map_eval_ctx as super method! visit_Symbolic env sv = - if same_symbolic_id sv.V.svalue original_sv then + if same_symbolic_id sv original_sv then let bid = fresh_borrow () in V.Borrow (V.SharedBorrow bid) else super#visit_Symbolic env sv @@ -326,7 +322,7 @@ let expand_symbolic_value_shared_borrow (config : C.config) (* Finally, replace the projectors on loans *) let bids = !borrows in assert (not (V.BorrowId.Set.is_empty bids)); - let ctx, shared_sv = mk_fresh_symbolic_proj_comp ended_regions ref_ty ctx in + let ctx, shared_sv = mk_fresh_symbolic_value ref_ty ctx in let see = SeSharedRef (bids, shared_sv) in let allow_reborrows = true in let ctx = @@ -339,17 +335,16 @@ let expand_symbolic_value_shared_borrow (config : C.config) ctx let expand_symbolic_value_borrow (config : C.config) - (original_sv : V.symbolic_value) (ended_regions : T.RegionId.set_t) - (region : T.RegionId.id T.region) (ref_ty : T.rty) (rkind : T.ref_kind) - (ctx : C.eval_ctx) : C.eval_ctx = + (original_sv : V.symbolic_value) (region : T.RegionId.id T.region) + (ref_ty : T.rty) (rkind : T.ref_kind) (ctx : C.eval_ctx) : C.eval_ctx = (* Check that we are allowed to expand the reference *) - assert (not (region_in_set region ended_regions)); + assert (not (region_in_set region ctx.ended_regions)); (* Match on the reference kind *) match rkind with | T.Mut -> (* Simple case: simply create a fresh symbolic value and a fresh * borrow id *) - let ctx, sv = mk_fresh_symbolic_proj_comp ended_regions ref_ty ctx in + let ctx, sv = mk_fresh_symbolic_value ref_ty ctx in let ctx, bid = C.fresh_borrow_id ctx in let see = SeMutRef (bid, sv) in (* Expand the symbolic values - we simply perform a substitution (and @@ -370,8 +365,7 @@ let expand_symbolic_value_borrow (config : C.config) (* Return *) ctx | T.Shared -> - expand_symbolic_value_shared_borrow config original_sv ended_regions - ref_ty ctx + expand_symbolic_value_shared_borrow config original_sv ref_ty ctx (** Expand a symbolic value which is not an enumeration with several variants (i.e., in a situation where it doesn't lead to branching). @@ -379,13 +373,12 @@ let expand_symbolic_value_borrow (config : C.config) This function is used when exploring paths. *) let expand_symbolic_value_no_branching (config : C.config) - (pe : E.projection_elem) (sp : V.symbolic_proj_comp) (ctx : C.eval_ctx) : + (pe : E.projection_elem) (sp : V.symbolic_value) (ctx : C.eval_ctx) : C.eval_ctx = (* Compute the expanded value - note that when doing so, we may introduce * fresh symbolic values in the context (which thus gets updated) *) - let original_sv = sp.V.svalue in + let original_sv = sp in let rty = original_sv.V.sv_ty in - let ended_regions = sp.V.rset_ended in let ctx = match (pe, rty) with (* "Regular" ADTs *) @@ -396,8 +389,8 @@ let expand_symbolic_value_no_branching (config : C.config) * don't allow to expand enumerations with strictly more than one variant *) let expand_enumerations = false in match - compute_expanded_symbolic_adt_value expand_enumerations ended_regions - def_id regions types ctx + compute_expanded_symbolic_adt_value expand_enumerations def_id regions + types ctx with | [ (ctx, see) ] -> (* Apply in the context *) @@ -413,9 +406,7 @@ let expand_symbolic_value_no_branching (config : C.config) | Field (ProjTuple arity, _), T.Adt (T.Tuple, [], tys) -> assert (arity = List.length tys); (* Generate the field values *) - let ctx, see = - compute_expanded_symbolic_tuple_value ended_regions tys ctx - in + let ctx, see = compute_expanded_symbolic_tuple_value tys ctx in (* Apply in the context *) let ctx = apply_symbolic_expansion_non_borrow config original_sv see ctx @@ -426,9 +417,7 @@ let expand_symbolic_value_no_branching (config : C.config) ctx (* Boxes *) | DerefBox, T.Adt (T.Assumed T.Box, [], [ boxed_ty ]) -> - let ctx, see = - compute_expanded_symbolic_box_value ended_regions boxed_ty ctx - in + let ctx, see = compute_expanded_symbolic_box_value boxed_ty ctx in (* Apply in the context *) let ctx = apply_symbolic_expansion_non_borrow config original_sv see ctx @@ -439,8 +428,7 @@ let expand_symbolic_value_no_branching (config : C.config) ctx (* Borrows *) | Deref, T.Ref (region, ref_ty, rkind) -> - expand_symbolic_value_borrow config original_sv ended_regions region - ref_ty rkind ctx + expand_symbolic_value_borrow config original_sv region ref_ty rkind ctx | _ -> failwith ("Unreachable: " ^ E.show_projection_elem pe ^ ", " ^ T.show_rty rty) @@ -454,13 +442,12 @@ let expand_symbolic_value_no_branching (config : C.config) This might lead to branching. *) -let expand_symbolic_enum_value (config : C.config) (sp : V.symbolic_proj_comp) +let expand_symbolic_enum_value (config : C.config) (sp : V.symbolic_value) (ctx : C.eval_ctx) : C.eval_ctx list = (* Compute the expanded value - note that when doing so, we may introduce * fresh symbolic values in the context (which thus gets updated) *) - let original_sv = sp.V.svalue in + let original_sv = sp in let rty = original_sv.V.sv_ty in - let ended_regions = sp.V.rset_ended in match rty with (* The value should be a "regular" ADTs *) | T.Adt (T.AdtId def_id, regions, types) -> @@ -468,8 +455,8 @@ let expand_symbolic_enum_value (config : C.config) (sp : V.symbolic_proj_comp) * don't allow to expand enumerations with strictly more than one variant *) let expand_enumerations = true in let res = - compute_expanded_symbolic_adt_value expand_enumerations ended_regions - def_id regions types ctx + compute_expanded_symbolic_adt_value expand_enumerations def_id regions + types ctx in (* Update the synthesized program *) let seel = List.map (fun (_, x) -> x) res in diff --git a/src/InterpreterExpressions.ml b/src/InterpreterExpressions.ml index e379eacd..f9b1ab3c 100644 --- a/src/InterpreterExpressions.ml +++ b/src/InterpreterExpressions.ml @@ -87,7 +87,7 @@ let eval_operand_prepare (config : C.config) (ctx : C.eval_ctx) (op : E.operand) let access = Move in prepare_rplace config access p ctx in - assert (not (bottom_in_value v)); + assert (not (bottom_in_value ctx.ended_regions v)); (ctx, v) (** Evaluate an operand. *) @@ -109,7 +109,7 @@ let eval_operand (config : C.config) (ctx : C.eval_ctx) (op : E.operand) : let ctx, v = prepare_rplace config access p ctx in (* Copy the value *) L.log#ldebug (lazy ("Value to copy:\n" ^ typed_value_to_string ctx v)); - assert (not (bottom_in_value v)); + assert (not (bottom_in_value ctx.ended_regions v)); let allow_adt_copy = false in copy_value allow_adt_copy config ctx v | Expressions.Move p -> ( @@ -118,7 +118,7 @@ let eval_operand (config : C.config) (ctx : C.eval_ctx) (op : E.operand) : let ctx, v = prepare_rplace config access p ctx in (* Move the value *) L.log#ldebug (lazy ("Value to move:\n" ^ typed_value_to_string ctx v)); - assert (not (bottom_in_value v)); + assert (not (bottom_in_value ctx.ended_regions v)); let bottom : V.typed_value = { V.value = Bottom; ty = v.ty } in match write_place config access p bottom ctx with | Error _ -> failwith "Unreachable" diff --git a/src/InterpreterPaths.ml b/src/InterpreterPaths.ml index 80725bab..bfe877ab 100644 --- a/src/InterpreterPaths.ml +++ b/src/InterpreterPaths.ml @@ -28,7 +28,7 @@ type path_fail_kind = | FailInactivatedMutBorrow of V.BorrowId.id (** Failure because we couldn't go inside an inactivated mutable borrow (which should get activated) *) - | FailSymbolic of (E.projection_elem * V.symbolic_proj_comp) + | FailSymbolic of (E.projection_elem * V.symbolic_value) (** Failure because we need to enter a symbolic value (and thus need to expand it) *) (* TODO: Remove the parentheses *) | FailBottom of (int * E.projection_elem * T.ety) @@ -774,8 +774,7 @@ let rec copy_value (allow_adt_copy : bool) (config : C.config) * Note that in the general case, copy is a trait: copying values * thus requires calling the proper function. Here, we copy values * for very simple types such as integers, shared borrows, etc. *) - assert ( - type_is_primitively_copyable (Subst.erase_regions sp.V.svalue.V.sv_ty)); + assert (type_is_primitively_copyable (Subst.erase_regions sp.V.sv_ty)); (* If the type is copyable, we simply return the current value. Side * remark: what is important to look at when copying symbolic values * is symbolic expansion. The important subcase is the expansion of shared diff --git a/src/InterpreterProjectors.ml b/src/InterpreterProjectors.ml index ada1a89a..21c9e034 100644 --- a/src/InterpreterProjectors.ml +++ b/src/InterpreterProjectors.ml @@ -13,9 +13,9 @@ open InterpreterBorrowsCore (** A symbolic expansion *) type symbolic_expansion = | SeConcrete of V.constant_value - | SeAdt of (T.VariantId.id option * V.symbolic_proj_comp list) - | SeMutRef of V.BorrowId.id * V.symbolic_proj_comp - | SeSharedRef of V.BorrowId.set_t * V.symbolic_proj_comp + | SeAdt of (T.VariantId.id option * V.symbolic_value list) + | SeMutRef of V.BorrowId.id * V.symbolic_value + | SeSharedRef of V.BorrowId.set_t * V.symbolic_value (** Auxiliary function. @@ -92,8 +92,9 @@ let rec apply_proj_borrows_on_shared_borrow (ctx : C.eval_ctx) asb | V.Loan _, _ -> failwith "Unreachable" | V.Symbolic s, _ -> - assert (not (symbolic_proj_comp_ended_regions_intersect_proj s ty regions)); - [ V.AsbProjReborrows (s.V.svalue, ty) ] + (* Check that the projection doesn't contain ended regions *) + assert (not (projections_intersect s.V.sv_ty ctx.ended_regions ty regions)); + [ V.AsbProjReborrows (s, ty) ] | _ -> failwith "Unreachable" (** Apply (and reduce) a projector over borrows to a value. @@ -212,12 +213,12 @@ let rec apply_proj_borrows (check_symbolic_no_ended : bool) (ctx : C.eval_ctx) V.ABorrow bc | V.Loan _, _ -> failwith "Unreachable" | V.Symbolic s, _ -> - (* Check that the symbolic value doesn't contain already ended regions, + (* Check that the projection doesn't contain already ended regions, * if necessary *) if check_symbolic_no_ended then assert ( - not (symbolic_proj_comp_ended_regions_intersect_proj s ty regions)); - V.ASymbolic (V.AProjBorrows (s.V.svalue, ty)) + not (projections_intersect s.V.sv_ty ctx.ended_regions ty regions)); + V.ASymbolic (V.AProjBorrows (s, ty)) | _ -> failwith "Unreachable" in { V.value; V.ty } @@ -231,7 +232,7 @@ let symbolic_expansion_non_borrow_to_value (sv : V.symbolic_value) | SeConcrete cv -> V.Concrete cv | SeAdt (variant_id, field_values) -> let field_values = - List.map mk_typed_value_from_proj_comp field_values + List.map mk_typed_value_from_symbolic_value field_values in V.Adt { V.variant_id; V.field_values } | SeMutRef (_, _) | SeSharedRef (_, _) -> @@ -250,7 +251,7 @@ let symbolic_expansion_non_shared_borrow_to_value (sv : V.symbolic_value) match see with | SeMutRef (bid, bv) -> let ty = Subst.erase_regions sv.V.sv_ty in - let bv = mk_typed_value_from_proj_comp bv in + let bv = mk_typed_value_from_symbolic_value bv in let value = V.Borrow (V.MutBorrow (bid, bv)) in { V.value; ty } | SeSharedRef (_, _) -> @@ -271,14 +272,14 @@ let apply_proj_loans_on_symbolic_expansion (regions : T.RegionId.set_t) | SeAdt (variant_id, field_values), T.Adt (_id, _region_params, _tys) -> (* Project over the field values *) let field_values = - List.map mk_aproj_loans_from_proj_comp field_values + List.map mk_aproj_loans_from_symbolic_value field_values in (V.AAdt { V.variant_id; field_values }, original_sv_ty) | SeMutRef (bid, spc), T.Ref (r, ref_ty, T.Mut) -> (* Sanity check *) - assert (spc.V.svalue.V.sv_ty = ref_ty); + assert (spc.V.sv_ty = ref_ty); (* Apply the projector to the borrowed value *) - let child_av = mk_aproj_loans_from_proj_comp spc in + let child_av = mk_aproj_loans_from_symbolic_value spc in (* Check if the region is in the set of projected regions (note that * we never project over static regions) *) if region_in_set r regions then @@ -289,14 +290,14 @@ let apply_proj_loans_on_symbolic_expansion (regions : T.RegionId.set_t) (V.ALoan (V.AIgnoredMutLoan (bid, child_av)), ref_ty) | SeSharedRef (bids, spc), T.Ref (r, ref_ty, T.Shared) -> (* Sanity check *) - assert (spc.V.svalue.V.sv_ty = ref_ty); + assert (spc.V.sv_ty = ref_ty); (* Apply the projector to the borrowed value *) - let child_av = mk_aproj_loans_from_proj_comp spc in + let child_av = mk_aproj_loans_from_symbolic_value spc in (* Check if the region is in the set of projected regions (note that * we never project over static regions) *) if region_in_set r regions then (* In the set: keep *) - let shared_value = mk_typed_value_from_proj_comp spc in + let shared_value = mk_typed_value_from_symbolic_value spc in (V.ALoan (V.ASharedLoan (bids, shared_value, child_av)), ref_ty) else (* Not in the set: ignore *) diff --git a/src/InterpreterStatements.ml b/src/InterpreterStatements.ml index 5eee5296..c4bbdf23 100644 --- a/src/InterpreterStatements.ml +++ b/src/InterpreterStatements.ml @@ -74,10 +74,8 @@ let eval_assertion (config : C.config) (ctx : C.eval_ctx) * `true` *) S.synthesize_assert v; let see = SeConcrete (V.Bool true) in - let ctx = - apply_symbolic_expansion_non_borrow config sv.V.svalue see ctx - in - S.synthesize_symbolic_expansion_no_branching sv.V.svalue see; + let ctx = apply_symbolic_expansion_non_borrow config sv see ctx in + S.synthesize_symbolic_expansion_no_branching sv see; (* We can finally fully evaluate the operand *) let ctx, _ = eval_operand config ctx assertion.cond in Ok ctx @@ -641,15 +639,13 @@ and eval_switch (config : C.config) (op : E.operand) (tgts : A.switch_targets) else eval_statement config ctx st2 | V.Symbolic sv -> (* Synthesis *) - S.synthesize_symbolic_expansion_if_branching sv.V.svalue; + S.synthesize_symbolic_expansion_if_branching sv; (* Expand the symbolic value to true or false *) let see_true = SeConcrete (V.Bool true) in let see_false = SeConcrete (V.Bool false) in let expand_and_execute see st = (* Apply the symbolic expansion *) - let ctx = - apply_symbolic_expansion_non_borrow config sv.V.svalue see ctx - in + let ctx = apply_symbolic_expansion_non_borrow config sv see ctx in (* Evaluate the operand *) let ctx, _ = eval_operand config ctx op in (* Evaluate the branch *) @@ -674,7 +670,7 @@ and eval_switch (config : C.config) (op : E.operand) (tgts : A.switch_targets) | Some (_, tgt) -> eval_statement config ctx tgt) | V.Symbolic sv -> (* Synthesis *) - S.synthesize_symbolic_expansion_switch_int_branching sv.V.svalue; + S.synthesize_symbolic_expansion_switch_int_branching sv; (* For all the branches of the switch, we expand the symbolic value * to the value given by the branch and execute the branch statement. * For the otherwise branch, we leave the symbolic value as it is @@ -685,9 +681,7 @@ and eval_switch (config : C.config) (op : E.operand) (tgts : A.switch_targets) let exec_branch (switch_value, branch_st) = let see = SeConcrete (V.Scalar switch_value) in (* Apply the symbolic expansion *) - let ctx = - apply_symbolic_expansion_non_borrow config sv.V.svalue see ctx - in + let ctx = apply_symbolic_expansion_non_borrow config sv see ctx in (* Evaluate the operand *) let ctx, _ = eval_operand config ctx op in (* Evaluate the branch *) @@ -810,11 +804,9 @@ and eval_function_call_symbolic_from_inst_sig (config : C.config) (args : E.operand list) (dest : E.place) : C.eval_ctx = (* Generate a fresh symbolic value for the return value *) let ret_sv_ty = inst_sg.A.output in - let ctx, ret_spc = - mk_fresh_symbolic_proj_comp T.RegionId.Set.empty ret_sv_ty ctx - in - let ret_value = mk_typed_value_from_proj_comp ret_spc in - let ret_av = mk_aproj_loans_from_symbolic_value ret_spc.V.svalue in + let ctx, ret_spc = mk_fresh_symbolic_value ret_sv_ty ctx in + let ret_value = mk_typed_value_from_symbolic_value ret_spc in + let ret_av = mk_aproj_loans_from_symbolic_value ret_spc in (* Evaluate the input operands *) let ctx, args = eval_operands config ctx args in let args_with_rtypes = List.combine args inst_sg.A.inputs in @@ -857,8 +849,7 @@ and eval_function_call_symbolic_from_inst_sig (config : C.config) (* Move the return value to its destination *) let ctx = assign_to_place config ctx ret_value dest in (* Synthesis *) - S.synthesize_function_call fid region_params type_params args dest - ret_spc.V.svalue; + S.synthesize_function_call fid region_params type_params args dest ret_spc; (* Return *) ctx diff --git a/src/InterpreterUtils.ml b/src/InterpreterUtils.ml index 458c11b4..fcc6050f 100644 --- a/src/InterpreterUtils.ml +++ b/src/InterpreterUtils.ml @@ -51,51 +51,19 @@ let mk_fresh_symbolic_value (ty : T.rty) (ctx : C.eval_ctx) : let svalue = { V.sv_id; V.sv_ty = ty } in (ctx, svalue) -(** Create a fresh symbolic proj comp *) -let mk_fresh_symbolic_proj_comp (ended_regions : T.RegionId.set_t) (ty : T.rty) - (ctx : C.eval_ctx) : C.eval_ctx * V.symbolic_proj_comp = - let ctx, svalue = mk_fresh_symbolic_value ty ctx in - let sv = { V.svalue; rset_ended = ended_regions } in - (ctx, sv) - -(** Create a fresh symbolic value (as a complementary projector) *) -let mk_fresh_symbolic_proj_comp_value (ended_regions : T.RegionId.set_t) - (ty : T.rty) (ctx : C.eval_ctx) : C.eval_ctx * V.typed_value = - let ctx, sv = mk_fresh_symbolic_proj_comp ended_regions ty ctx in - let value : V.value = V.Symbolic sv in - let ty : T.ety = Subst.erase_regions ty in - let sv : V.typed_value = { V.value; ty } in - (ctx, sv) - -let mk_typed_value_from_proj_comp (sv : V.symbolic_proj_comp) : V.typed_value = - let ty = Subst.erase_regions sv.V.svalue.V.sv_ty in - let value = V.Symbolic sv in - { V.value; ty } - -(** Create a typed value from a symbolic value. - - Initializes the set of ended regions with `empty`. - *) +(** Create a typed value from a symbolic value. *) let mk_typed_value_from_symbolic_value (svalue : V.symbolic_value) : V.typed_value = - let spc = { V.svalue; rset_ended = T.RegionId.Set.empty } in - mk_typed_value_from_proj_comp spc - -let mk_aproj_loans_from_proj_comp (spc : V.symbolic_proj_comp) : V.typed_avalue - = - let ty = spc.V.svalue.V.sv_ty in - let proj = V.AProjLoans spc.V.svalue in - let value = V.ASymbolic proj in - { V.value; ty } - -(** Create a Loans projector from a symbolic value. + let av = V.Symbolic svalue in + let av : V.typed_value = + { V.value = av; V.ty = Subst.erase_regions svalue.V.sv_ty } + in + av - Initializes the set of ended regions with `empty`. - *) +(** Create a loans projector from a symbolic value. *) let mk_aproj_loans_from_symbolic_value (svalue : V.symbolic_value) : V.typed_avalue = - let spc = { V.svalue; rset_ended = T.RegionId.Set.empty } in - let av = V.ASymbolic (V.AProjLoans spc.V.svalue) in + let av = V.ASymbolic (V.AProjLoans svalue) in let av : V.typed_avalue = { V.value = av; V.ty = svalue.V.sv_ty } in av @@ -162,7 +130,7 @@ let symbolic_value_id_in_ctx (sv_id : V.SymbolicValueId.id) (ctx : C.eval_ctx) : inherit [_] C.iter_eval_ctx method! visit_Symbolic _ sv = - if sv.V.svalue.V.sv_id = sv_id then raise Found else () + if sv.V.sv_id = sv_id then raise Found else () method! visit_ASymbolic _ aproj = match aproj with @@ -228,36 +196,33 @@ let rec projections_intersect (ty1 : T.rty) (rset1 : T.RegionId.set_t) || projections_intersect ty1 rset1 ty2 rset2 | _ -> failwith "Unreachable" -(** Check if the ended regions of a comp projector over a symbolic value - intersect the regions listed in another projection *) -let symbolic_proj_comp_ended_regions_intersect_proj (s : V.symbolic_proj_comp) - (ty : T.rty) (regions : T.RegionId.set_t) : bool = - projections_intersect s.V.svalue.V.sv_ty s.V.rset_ended ty regions - (** Check that a symbolic value doesn't contain ended regions. Note that we don't check that the set of ended regions is empty: we check that the set of ended regions doesn't intersect the set of regions used in the type (this is more general). *) -let symbolic_proj_comp_ended_regions (s : V.symbolic_proj_comp) : bool = - let regions = rty_regions s.V.svalue.V.sv_ty in - not (T.RegionId.Set.disjoint regions s.rset_ended) +let symbolic_value_has_ended_regions (ended_regions : T.RegionId.set_t) + (s : V.symbolic_value) : bool = + let regions = rty_regions s.V.sv_ty in + not (T.RegionId.Set.disjoint regions ended_regions) (** Check if a [value] contains ⊥. Note that this function is very general: it also checks wether symbolic values contain already ended regions. *) -let bottom_in_value (v : V.typed_value) : bool = +let bottom_in_value (ended_regions : T.RegionId.set_t) (v : V.typed_value) : + bool = let obj = object inherit [_] V.iter_typed_value method! visit_Bottom _ = raise Found - method! visit_symbolic_proj_comp _ s = - if symbolic_proj_comp_ended_regions s then raise Found else () + method! visit_symbolic_value _ s = + if symbolic_value_has_ended_regions ended_regions s then raise Found + else () end in (* We use exceptions *) @@ -273,7 +238,7 @@ let bottom_in_value (v : V.typed_value) : bool = TODO: remove? *) -let bottom_in_avalue (v : V.typed_avalue) (_abs_regions : T.RegionId.set_t) : +let bottom_in_avalue (ended_regions : T.RegionId.set_t) (v : V.typed_avalue) : bool = let obj = object @@ -281,8 +246,9 @@ let bottom_in_avalue (v : V.typed_avalue) (_abs_regions : T.RegionId.set_t) : method! visit_Bottom _ = raise Found - method! visit_symbolic_proj_comp _ sv = - if symbolic_proj_comp_ended_regions sv then raise Found else () + method! visit_symbolic_value _ sv = + if symbolic_value_has_ended_regions ended_regions sv then raise Found + else () method! visit_aproj _ ap = (* Nothing to do actually *) diff --git a/src/Invariants.ml b/src/Invariants.ml index 11b00381..86fa3d46 100644 --- a/src/Invariants.ml +++ b/src/Invariants.ml @@ -433,8 +433,8 @@ let check_typing_invariant (ctx : C.eval_ctx) : unit = | Abstract (V.AMutBorrow (_, sv)) -> assert (Subst.erase_regions sv.V.ty = ty) | _ -> failwith "Inconsistent context")) - | V.Symbolic spc, ty -> - let ty' = Subst.erase_regions spc.V.svalue.V.sv_ty in + | V.Symbolic sv, ty -> + let ty' = Subst.erase_regions sv.V.sv_ty in assert (ty' = ty) | _ -> failwith "Erroneous typing"); (* Continue exploring to inspect the subterms *) diff --git a/src/Print.ml b/src/Print.ml index 0b436f1a..f714e847 100644 --- a/src/Print.ml +++ b/src/Print.ml @@ -214,11 +214,6 @@ module Values = struct (sv : V.symbolic_value) : string = symbolic_value_id_to_string sv.sv_id ^ " : " ^ PT.rty_to_string fmt sv.sv_ty - let symbolic_proj_comp_to_string (fmt : PT.rtype_formatter) - (sp : V.symbolic_proj_comp) : string = - let regions = T.RegionId.set_to_string sp.rset_ended in - "proj_comp " ^ regions ^ " (" ^ symbolic_value_to_string fmt sp.svalue ^ ")" - let symbolic_value_proj_to_string (fmt : value_formatter) (sv : V.symbolic_value) (rty : T.rty) : string = symbolic_value_id_to_string sv.sv_id @@ -275,8 +270,7 @@ module Values = struct | Bottom -> "⊥ : " ^ PT.ty_to_string ty_fmt v.ty | Borrow bc -> borrow_content_to_string fmt bc | Loan lc -> loan_content_to_string fmt lc - | Symbolic s -> - symbolic_proj_comp_to_string (value_to_rtype_formatter fmt) s + | Symbolic s -> symbolic_value_to_string (value_to_rtype_formatter fmt) s and borrow_content_to_string (fmt : value_formatter) (bc : V.borrow_content) : string = @@ -539,6 +533,7 @@ module Contexts = struct let eval_ctx_to_string (ctx : C.eval_ctx) : string = let fmt = eval_ctx_to_ctx_formatter ctx in + let ended_regions = T.RegionId.set_to_string ctx.ended_regions in let frames = split_env_according_to_frames ctx.env in let num_frames = List.length frames in let frames = @@ -547,7 +542,8 @@ module Contexts = struct "\n# Frame " ^ string_of_int i ^ ":\n" ^ env_to_string fmt f ^ "\n") frames in - "# " ^ string_of_int num_frames ^ " frame(s)\n" ^ String.concat "" frames + "# Ended regions: " ^ ended_regions ^ "\n" ^ "# " ^ string_of_int num_frames + ^ " frame(s)\n" ^ String.concat "" frames end module PC = Contexts (* local module *) diff --git a/src/Values.ml b/src/Values.ml index 47bdda23..b6bb414b 100644 --- a/src/Values.ml +++ b/src/Values.ml @@ -47,35 +47,7 @@ type constant_value = type symbolic_value = { sv_id : SymbolicValueId.id; sv_ty : rty } [@@deriving show] -(** Symbolic value. - - TODO: a symbolic value may not always have the same type!! - For references: - - a projector on loans may see a symbolic value of id `sid` as having type `T` - - a projector on borrows may see it as having type `&mut T` - We need to make this clear and more consistant. - So [symbolic_value] is actually a projector. TODO: rename to [symbolic_proj]. - The kind of projector will then depend on the context. - Actually, maybe we shouldn't use this type. Or for abstractions we should - use different types. Something like: - - [proj_borrows] for values - - [aproj_loans], [aproj_borrows] for avalues - *) - -(** TODO: make it clear that complementary projectors are projectors on borrows. - ** TODO: actually this is useless: the set of ended regions should be global! - ** (and thus stored in the context) *) -type symbolic_proj_comp = { - svalue : symbolic_value; (** The symbolic value itself *) - rset_ended : RegionId.set_t; - (** The regions used in the symbolic value which have already ended *) -} -[@@deriving show] -(** A complementary projector over a symbolic value. - - "Complementary" stands for the fact that it is a projector over all the - regions *but* the ones which are listed in the projector. -*) +(** A symbolic value *) (** Ancestor for [typed_value] iter visitor *) class ['self] iter_typed_value_base = @@ -86,8 +58,7 @@ class ['self] iter_typed_value_base = method visit_erased_region : 'env -> erased_region -> unit = fun _ _ -> () - method visit_symbolic_proj_comp : 'env -> symbolic_proj_comp -> unit = - fun _ _ -> () + method visit_symbolic_value : 'env -> symbolic_value -> unit = fun _ _ -> () method visit_ety : 'env -> ety -> unit = fun _ _ -> () end @@ -103,8 +74,7 @@ class ['self] map_typed_value_base = method visit_erased_region : 'env -> erased_region -> erased_region = fun _ r -> r - method visit_symbolic_proj_comp - : 'env -> symbolic_proj_comp -> symbolic_proj_comp = + method visit_symbolic_value : 'env -> symbolic_value -> symbolic_value = fun _ sv -> sv method visit_ety : 'env -> ety -> ety = fun _ ty -> ty @@ -117,8 +87,13 @@ type value = | Bottom (** No value (uninitialized or moved value) *) | Borrow of borrow_content (** A borrowed value *) | Loan of loan_content (** A loaned value *) - | Symbolic of symbolic_proj_comp - (** Unknown (symbolic) value. This is a projector on borrows (TODO: make this clearer). *) + | Symbolic of symbolic_value + (** Borrow projector over a symbolic value. + + Note that contrary to the abstraction-values case, symbolic values + appearing in regular values are interpreted as *borrow* projectors, + they can never be *loan* projectors. + *) and adt_value = { variant_id : (VariantId.id option[@opaque]); -- cgit v1.2.3 From f3982cbe9782405b50b04c948ba7cb0bd89ef85f Mon Sep 17 00:00:00 2001 From: Son Ho Date: Thu, 6 Jan 2022 18:20:24 +0100 Subject: Make the symbolic, borrow, region and abstration counters global and stateful --- src/Contexts.ml | 63 ++++++++++++++++++++++++++--------------- src/Identifiers.ml | 11 ++++++++ src/Interpreter.ml | 11 ++------ src/InterpreterBorrows.ml | 9 +++--- src/InterpreterExpansion.ml | 65 +++++++++++++++++++------------------------ src/InterpreterExpressions.ml | 8 +++--- src/InterpreterPaths.ml | 2 +- src/InterpreterProjectors.ml | 8 +----- src/InterpreterStatements.ml | 12 ++++---- src/InterpreterUtils.ml | 7 ++--- src/Substitute.ml | 12 +++----- 11 files changed, 104 insertions(+), 104 deletions(-) (limited to 'src') diff --git a/src/Contexts.ml b/src/Contexts.ml index 5225645c..f8a7b56b 100644 --- a/src/Contexts.ml +++ b/src/Contexts.ml @@ -3,6 +3,46 @@ open Values open CfimAst module V = Values +(** Some global counters. + * + * Note that those counters were initially stored in [eval_ctx] values, + * but it proved better to make them global and stateful: + * - when branching (and thus executing on several paths with different + * contexts) it is better to really have unique ids everywhere (and + * not have fresh ids shared by several contexts even though introduced + * after the branching) because at some point we might need to merge the + * different contexts + * - also, it is a lot more convenient to not store those counters in contexts + * objects + *) + +let symbolic_value_id_counter, fresh_symbolic_value_id = + SymbolicValueId.fresh_stateful_generator () + +let borrow_id_counter, fresh_borrow_id = BorrowId.fresh_stateful_generator () + +let region_id_counter, fresh_region_id = RegionId.fresh_stateful_generator () + +let abstraction_id_counter, fresh_abstraction_id = + AbstractionId.fresh_stateful_generator () + +(** We shouldn't need to reset the global counters, but it might be good to + to it from time to time, every time we evaluate/synthesize a function for + instance. + + The reasons are manifold: + - it might prevent the counters from overflowing (although this seems + extremely unlikely - as a side node: we have overflow checks to make + sure the synthesis doesn't get impacted by potential overflows) + - most importantly, it allows to always manipulate low values, which + is always a lot more readable when debugging + *) +let reset_global_counters () = + symbolic_value_id_counter := SymbolicValueId.generator_zero; + borrow_id_counter := BorrowId.generator_zero; + region_id_counter := RegionId.generator_zero; + abstraction_id_counter := AbstractionId.generator_zero + type binder = { index : VarId.id; (** Unique variable identifier *) name : string option; (** Possible name *) @@ -68,33 +108,10 @@ type eval_ctx = { type_vars : type_var list; env : env; ended_regions : RegionId.set_t; - symbolic_counter : SymbolicValueId.generator; - (* TODO: make this global? *) - borrow_counter : BorrowId.generator; - (* TODO: make this global? *) - region_counter : RegionId.generator; - (* TODO: make this global? *) - abstraction_counter : AbstractionId.generator; (* TODO: make this global? *) } [@@deriving show] (** Evaluation context *) -let fresh_symbolic_value_id (ctx : eval_ctx) : eval_ctx * SymbolicValueId.id = - let id, counter' = SymbolicValueId.fresh ctx.symbolic_counter in - ({ ctx with symbolic_counter = counter' }, id) - -let fresh_borrow_id (ctx : eval_ctx) : eval_ctx * BorrowId.id = - let id, counter' = BorrowId.fresh ctx.borrow_counter in - ({ ctx with borrow_counter = counter' }, id) - -let fresh_region_id (ctx : eval_ctx) : eval_ctx * RegionId.id = - let id, counter' = RegionId.fresh ctx.region_counter in - ({ ctx with region_counter = counter' }, id) - -let fresh_abstraction_id (ctx : eval_ctx) : eval_ctx * AbstractionId.id = - let id, counter' = AbstractionId.fresh ctx.abstraction_counter in - ({ ctx with abstraction_counter = counter' }, id) - let lookup_type_var (ctx : eval_ctx) (vid : TypeVarId.id) : type_var = TypeVarId.nth ctx.type_vars vid diff --git a/src/Identifiers.ml b/src/Identifiers.ml index 345ce058..d3e5b83e 100644 --- a/src/Identifiers.ml +++ b/src/Identifiers.ml @@ -16,6 +16,8 @@ module type Id = sig val generator_zero : generator + val fresh_stateful_generator : unit -> generator ref * (unit -> id) + (* TODO: this is stateful! - but we may want to be able to duplicate contexts... *) val fresh : generator -> id * generator (* TODO: change the order of the returned types *) @@ -84,6 +86,15 @@ module IdGen () : Id = struct * they happen *) if x == max_int then raise (Errors.IntegerOverflow ()) else x + 1 + let fresh_stateful_generator () = + let g = ref 0 in + let fresh () = + let id = !g in + g := incr id; + id + in + (g, fresh) + let fresh gen = (gen, incr gen) let to_string = string_of_int diff --git a/src/Interpreter.ml b/src/Interpreter.ml index 54911d85..ec15093d 100644 --- a/src/Interpreter.ml +++ b/src/Interpreter.ml @@ -25,16 +25,13 @@ open InterpreterStatements module Test = struct let initialize_context (type_context : C.type_context) (fun_defs : A.fun_def list) (type_vars : T.type_var list) : C.eval_ctx = + C.reset_global_counters (); { C.type_context; C.fun_context = fun_defs; C.type_vars; C.env = []; C.ended_regions = T.RegionId.Set.empty; - C.symbolic_counter = V.SymbolicValueId.generator_zero; - C.borrow_counter = V.BorrowId.generator_zero; - C.region_counter = T.RegionId.generator_zero; - C.abstraction_counter = V.AbstractionId.generator_zero; } (** Initialize an evaluation context to execute a function. @@ -67,10 +64,8 @@ module Test = struct in let ctx, inst_sg = instantiate_fun_sig type_params sg ctx in (* Create fresh symbolic values for the inputs *) - let ctx, input_svs = - List.fold_left_map - (fun ctx ty -> mk_fresh_symbolic_value ty ctx) - ctx inst_sg.inputs + let input_svs = + List.map (fun ty -> mk_fresh_symbolic_value ty) inst_sg.inputs in (* Create the abstractions and insert them in the context *) let create_abs (ctx : C.eval_ctx) (rg : A.abs_region_group) : C.eval_ctx = diff --git a/src/InterpreterBorrows.ml b/src/InterpreterBorrows.ml index 3cfa78e0..a18ccefb 100644 --- a/src/InterpreterBorrows.ml +++ b/src/InterpreterBorrows.ml @@ -619,15 +619,14 @@ let give_back (config : C.config) (l : V.BorrowId.id) (bc : g_borrow_content) be expanded (because expanding this symbolic value would require expanding a reference whose region has already ended). *) -let convert_avalue_to_value (av : V.typed_avalue) (ctx : C.eval_ctx) : - C.eval_ctx * V.typed_value = +let convert_avalue_to_value (av : V.typed_avalue) : V.typed_value = (* Convert the type *) let ty = Subst.erase_regions av.V.ty in (* Generate the fresh a symbolic value *) - let ctx, sv_id = C.fresh_symbolic_value_id ctx in + let sv_id = C.fresh_symbolic_value_id () in let svalue : V.symbolic_value = { V.sv_id; sv_ty = av.V.ty } in let value = V.Symbolic svalue in - (ctx, { V.value; V.ty }) + { V.value; V.ty } (** End a borrow identified by its borrow id in a context @@ -901,7 +900,7 @@ and end_abstraction_borrows (config : C.config) (abs_id : V.AbstractionId.id) match bc with | V.AMutBorrow (bid, av) -> (* First, convert the avalue to a (fresh symbolic) value *) - let ctx, v = convert_avalue_to_value av ctx in + let v = convert_avalue_to_value av in give_back_value config bid v ctx | V.ASharedBorrow bid -> give_back_shared config bid ctx | V.AProjSharedBorrow _ -> diff --git a/src/InterpreterExpansion.ml b/src/InterpreterExpansion.ml index 24ec018e..2de06f24 100644 --- a/src/InterpreterExpansion.ml +++ b/src/InterpreterExpansion.ml @@ -183,16 +183,15 @@ let apply_symbolic_expansion_non_borrow (config : C.config) (** Compute the expansion of an adt value. - The function might return a list of contexts and values if the symbolic - value to expand is an enumeration. + The function might return a list of values if the symbolic value to expand + is an enumeration. `expand_enumerations` controls the expansion of enumerations: if false, it doesn't allow the expansion of enumerations *containing several variants*. *) let compute_expanded_symbolic_adt_value (expand_enumerations : bool) (def_id : T.TypeDefId.id) (regions : T.RegionId.id T.region list) - (types : T.rty list) (ctx : C.eval_ctx) : - (C.eval_ctx * symbolic_expansion) list = + (types : T.rty list) (ctx : C.eval_ctx) : symbolic_expansion list = (* Lookup the definition and check if it is an enumeration with several * variants *) let def = C.ctx_lookup_type_def ctx def_id in @@ -205,38 +204,34 @@ let compute_expanded_symbolic_adt_value (expand_enumerations : bool) if List.length variants_fields_types > 1 && not expand_enumerations then failwith "Not allowed to expand enumerations with several variants"; (* Initialize the expanded value for a given variant *) - let initialize (ctx : C.eval_ctx) + let initialize ((variant_id, field_types) : T.VariantId.id option * T.rty list) : - C.eval_ctx * symbolic_expansion = - let ctx, field_values = - List.fold_left_map - (fun ctx (ty : T.rty) -> mk_fresh_symbolic_value ty ctx) - ctx field_types + symbolic_expansion = + let field_values = + List.map (fun (ty : T.rty) -> mk_fresh_symbolic_value ty) field_types in let see = SeAdt (variant_id, field_values) in - (ctx, see) + see in (* Initialize all the expanded values of all the variants *) - List.map (initialize ctx) variants_fields_types + List.map initialize variants_fields_types -let compute_expanded_symbolic_tuple_value (field_types : T.rty list) - (ctx : C.eval_ctx) : C.eval_ctx * symbolic_expansion = +let compute_expanded_symbolic_tuple_value (field_types : T.rty list) : + symbolic_expansion = (* Generate the field values *) - let ctx, field_values = - List.fold_left_map - (fun ctx sv_ty -> mk_fresh_symbolic_value sv_ty ctx) - ctx field_types + let field_values = + List.map (fun sv_ty -> mk_fresh_symbolic_value sv_ty) field_types in let variant_id = None in let see = SeAdt (variant_id, field_values) in - (ctx, see) + see -let compute_expanded_symbolic_box_value (boxed_ty : T.rty) (ctx : C.eval_ctx) : - C.eval_ctx * symbolic_expansion = +let compute_expanded_symbolic_box_value (boxed_ty : T.rty) : symbolic_expansion + = (* Introduce a fresh symbolic value *) - let ctx, boxed_value = mk_fresh_symbolic_value boxed_ty ctx in + let boxed_value = mk_fresh_symbolic_value boxed_ty in let see = SeAdt (None, [ boxed_value ]) in - (ctx, see) + see let expand_symbolic_value_shared_borrow (config : C.config) (original_sv : V.symbolic_value) (ref_ty : T.rty) (ctx : C.eval_ctx) : @@ -247,10 +242,8 @@ let expand_symbolic_value_shared_borrow (config : C.config) * one fresh borrow id per instance. *) let borrows = ref V.BorrowId.Set.empty in - let borrow_counter = ref ctx.C.borrow_counter in let fresh_borrow () = - let bid', cnt' = V.BorrowId.fresh !borrow_counter in - borrow_counter := cnt'; + let bid' = C.fresh_borrow_id () in borrows := V.BorrowId.Set.add bid' !borrows; bid' in @@ -318,11 +311,10 @@ let expand_symbolic_value_shared_borrow (config : C.config) in (* Call the visitor *) let ctx = obj#visit_eval_ctx None ctx in - let ctx = { ctx with C.borrow_counter = !borrow_counter } in (* Finally, replace the projectors on loans *) let bids = !borrows in assert (not (V.BorrowId.Set.is_empty bids)); - let ctx, shared_sv = mk_fresh_symbolic_value ref_ty ctx in + let shared_sv = mk_fresh_symbolic_value ref_ty in let see = SeSharedRef (bids, shared_sv) in let allow_reborrows = true in let ctx = @@ -344,8 +336,8 @@ let expand_symbolic_value_borrow (config : C.config) | T.Mut -> (* Simple case: simply create a fresh symbolic value and a fresh * borrow id *) - let ctx, sv = mk_fresh_symbolic_value ref_ty ctx in - let ctx, bid = C.fresh_borrow_id ctx in + let sv = mk_fresh_symbolic_value ref_ty in + let bid = C.fresh_borrow_id () in let see = SeMutRef (bid, sv) in (* Expand the symbolic values - we simply perform a substitution (and * check that we perform exactly one substitution) *) @@ -392,7 +384,7 @@ let expand_symbolic_value_no_branching (config : C.config) compute_expanded_symbolic_adt_value expand_enumerations def_id regions types ctx with - | [ (ctx, see) ] -> + | [ see ] -> (* Apply in the context *) let ctx = apply_symbolic_expansion_non_borrow config original_sv see ctx @@ -406,7 +398,7 @@ let expand_symbolic_value_no_branching (config : C.config) | Field (ProjTuple arity, _), T.Adt (T.Tuple, [], tys) -> assert (arity = List.length tys); (* Generate the field values *) - let ctx, see = compute_expanded_symbolic_tuple_value tys ctx in + let see = compute_expanded_symbolic_tuple_value tys in (* Apply in the context *) let ctx = apply_symbolic_expansion_non_borrow config original_sv see ctx @@ -417,7 +409,7 @@ let expand_symbolic_value_no_branching (config : C.config) ctx (* Boxes *) | DerefBox, T.Adt (T.Assumed T.Box, [], [ boxed_ty ]) -> - let ctx, see = compute_expanded_symbolic_box_value boxed_ty ctx in + let see = compute_expanded_symbolic_box_value boxed_ty in (* Apply in the context *) let ctx = apply_symbolic_expansion_non_borrow config original_sv see ctx @@ -454,15 +446,14 @@ let expand_symbolic_enum_value (config : C.config) (sp : V.symbolic_value) (* Compute the expanded value - there should be exactly one because we * don't allow to expand enumerations with strictly more than one variant *) let expand_enumerations = true in - let res = + let seel = compute_expanded_symbolic_adt_value expand_enumerations def_id regions types ctx in (* Update the synthesized program *) - let seel = List.map (fun (_, x) -> x) res in S.synthesize_symbolic_expansion_enum_branching original_sv seel; (* Apply in the context *) - let apply (ctx, see) : C.eval_ctx = + let apply see : C.eval_ctx = let ctx = apply_symbolic_expansion_non_borrow config original_sv see ctx in @@ -471,5 +462,5 @@ let expand_symbolic_enum_value (config : C.config) (sp : V.symbolic_value) (* Return *) ctx in - List.map apply res + List.map apply seel | _ -> failwith "Unexpected" diff --git a/src/InterpreterExpressions.ml b/src/InterpreterExpressions.ml index f9b1ab3c..0b4bc90f 100644 --- a/src/InterpreterExpressions.ml +++ b/src/InterpreterExpressions.ml @@ -157,7 +157,7 @@ let eval_unary_op_symbolic (config : C.config) (ctx : C.eval_ctx) (* Evaluate the operand *) let ctx, v = eval_operand config ctx op in (* Generate a fresh symbolic value to store the result *) - let ctx, res_sv_id = C.fresh_symbolic_value_id ctx in + let res_sv_id = C.fresh_symbolic_value_id () in let res_sv_ty = match (unop, v.V.ty) with | E.Not, T.Bool -> T.Bool @@ -258,7 +258,7 @@ let eval_binary_op_symbolic (config : C.config) (ctx : C.eval_ctx) (* Evaluate the operands *) let ctx, v1, v2 = eval_two_operands config ctx op1 op2 in (* Generate a fresh symbolic value to store the result *) - let ctx, res_sv_id = C.fresh_symbolic_value_id ctx in + let res_sv_id = C.fresh_symbolic_value_id () in let res_sv_ty = if binop = Eq || binop = Ne then ( (* Equality operations *) @@ -343,7 +343,7 @@ let eval_rvalue_ref (config : C.config) (ctx : C.eval_ctx) (p : E.place) let access = if bkind = E.Shared then Read else Write in let ctx, v = prepare_rplace config access p ctx in (* Compute the rvalue - simply a shared borrow with a fresh id *) - let ctx, bid = C.fresh_borrow_id ctx in + let bid = C.fresh_borrow_id () in (* Note that the reference is *mutable* if we do a two-phase borrow *) let rv_ty = T.Ref (T.Erased, v.ty, if bkind = E.Shared then Shared else Mut) @@ -374,7 +374,7 @@ let eval_rvalue_ref (config : C.config) (ctx : C.eval_ctx) (p : E.place) let access = Write in let ctx, v = prepare_rplace config access p ctx in (* Compute the rvalue - wrap the value in a mutable borrow with a fresh id *) - let ctx, bid = C.fresh_borrow_id ctx in + let bid = C.fresh_borrow_id () in let rv_ty = T.Ref (T.Erased, v.ty, Mut) in let rv : V.typed_value = { V.value = V.Borrow (V.MutBorrow (bid, v)); ty = rv_ty } diff --git a/src/InterpreterPaths.ml b/src/InterpreterPaths.ml index bfe877ab..07c615a0 100644 --- a/src/InterpreterPaths.ml +++ b/src/InterpreterPaths.ml @@ -756,7 +756,7 @@ let rec copy_value (allow_adt_copy : bool) (config : C.config) | SharedBorrow bid -> (* We need to create a new borrow id for the copied borrow, and * update the context accordingly *) - let ctx, bid' = C.fresh_borrow_id ctx in + let bid' = C.fresh_borrow_id () in let ctx = reborrow_shared bid bid' ctx in (ctx, { v with V.value = V.Borrow (SharedBorrow bid') }) | MutBorrow (_, _) -> failwith "Can't copy a mutable borrow" diff --git a/src/InterpreterProjectors.ml b/src/InterpreterProjectors.ml index 21c9e034..3fa824ab 100644 --- a/src/InterpreterProjectors.ml +++ b/src/InterpreterProjectors.ml @@ -475,12 +475,10 @@ let prepare_reborrows (config : C.config) (allow_reborrows : bool) (ctx : C.eval_ctx) : (V.BorrowId.id -> V.BorrowId.id) * (C.eval_ctx -> C.eval_ctx) = let reborrows : (V.BorrowId.id * V.BorrowId.id) list ref = ref [] in - let borrow_counter = ref ctx.C.borrow_counter in (* The function to generate and register fresh reborrows *) let fresh_reborrow (bid : V.BorrowId.id) : V.BorrowId.id = if allow_reborrows then ( - let bid', cnt' = V.BorrowId.fresh !borrow_counter in - borrow_counter := cnt'; + let bid' = C.fresh_borrow_id () in reborrows := (bid, bid') :: !reborrows; bid') else failwith "Unexpected reborrow" @@ -489,13 +487,9 @@ let prepare_reborrows (config : C.config) (allow_reborrows : bool) let apply_registered_reborrows (ctx : C.eval_ctx) : C.eval_ctx = match config.C.mode with | C.ConcreteMode -> - (* Reborrows are introduced when applying projections in symbolic mode *) - assert (!borrow_counter = ctx.C.borrow_counter); assert (!reborrows = []); ctx | C.SymbolicMode -> - (* Update the borrow counter *) - let ctx = { ctx with C.borrow_counter = !borrow_counter } in (* Apply the reborrows *) apply_reborrows !reborrows ctx in diff --git a/src/InterpreterStatements.ml b/src/InterpreterStatements.ml index c4bbdf23..36d11a9e 100644 --- a/src/InterpreterStatements.ml +++ b/src/InterpreterStatements.ml @@ -362,9 +362,9 @@ let eval_box_deref_mut_or_shared_inst_sig (region_params : T.erased_region list) `&'a (mut) Box -> &'a (mut) T` where T is the type param *) - let ctx, rid = C.fresh_region_id ctx in + let rid = C.fresh_region_id () in let r = T.Var rid in - let ctx, abs_id = C.fresh_abstraction_id ctx in + let abs_id = C.fresh_abstraction_id () in match (region_params, type_params) with | [], [ ty_param ] -> let ty_param = ety_no_regions_to_rty ty_param in @@ -477,7 +477,7 @@ let instantiate_fun_sig (type_params : T.ety list) (sg : A.fun_sig) let ctx, rg_abs_ids_bindings = List.fold_left_map (fun ctx rg -> - let ctx, abs_id = C.fresh_abstraction_id ctx in + let abs_id = C.fresh_abstraction_id () in (ctx, (rg.A.id, abs_id))) ctx sg.regions_hierarchy in @@ -490,9 +490,7 @@ let instantiate_fun_sig (type_params : T.ety list) (sg : A.fun_sig) A.RegionGroupId.Map.find rg_id asubst_map in (* Generate fresh regions and their substitutions *) - let ctx, _, rsubst, _ = - Subst.fresh_regions_with_substs sg.region_params ctx - in + let _, rsubst, _ = Subst.fresh_regions_with_substs sg.region_params in (* Generate the type substitution * Note that we need the substitution to map the type variables to * [rty] types (not [ety]). In order to do that, we convert the @@ -804,7 +802,7 @@ and eval_function_call_symbolic_from_inst_sig (config : C.config) (args : E.operand list) (dest : E.place) : C.eval_ctx = (* Generate a fresh symbolic value for the return value *) let ret_sv_ty = inst_sg.A.output in - let ctx, ret_spc = mk_fresh_symbolic_value ret_sv_ty ctx in + let ret_spc = mk_fresh_symbolic_value ret_sv_ty in let ret_value = mk_typed_value_from_symbolic_value ret_spc in let ret_av = mk_aproj_loans_from_symbolic_value ret_spc in (* Evaluate the input operands *) diff --git a/src/InterpreterUtils.ml b/src/InterpreterUtils.ml index fcc6050f..40ef0d05 100644 --- a/src/InterpreterUtils.ml +++ b/src/InterpreterUtils.ml @@ -45,11 +45,10 @@ let mk_place_from_var_id (var_id : V.VarId.id) : E.place = { var_id; projection = [] } (** Create a fresh symbolic value *) -let mk_fresh_symbolic_value (ty : T.rty) (ctx : C.eval_ctx) : - C.eval_ctx * V.symbolic_value = - let ctx, sv_id = C.fresh_symbolic_value_id ctx in +let mk_fresh_symbolic_value (ty : T.rty) : V.symbolic_value = + let sv_id = C.fresh_symbolic_value_id () in let svalue = { V.sv_id; V.sv_ty = ty } in - (ctx, svalue) + svalue (** Create a typed value from a symbolic value. *) let mk_typed_value_from_symbolic_value (svalue : V.symbolic_value) : diff --git a/src/Substitute.ml b/src/Substitute.ml index 1b6003bb..62a737ad 100644 --- a/src/Substitute.ml +++ b/src/Substitute.ml @@ -42,16 +42,12 @@ let erase_regions (ty : T.rty) : T.ety = TODO: simplify? we only need the subst `T.RegionVarId.id -> T.RegionId.id` *) -let fresh_regions_with_substs (region_vars : T.region_var list) - (ctx : C.eval_ctx) : - C.eval_ctx - * T.RegionId.id list +let fresh_regions_with_substs (region_vars : T.region_var list) : + T.RegionId.id list * (T.RegionVarId.id -> T.RegionId.id) * (T.RegionVarId.id T.region -> T.RegionId.id T.region) = (* Generate fresh regions *) - let ctx, fresh_region_ids = - List.fold_left_map (fun ctx _ -> C.fresh_region_id ctx) ctx region_vars - in + let fresh_region_ids = List.map (fun _ -> C.fresh_region_id ()) region_vars in (* Generate the map from region var ids to regions *) let ls = List.combine region_vars fresh_region_ids in let rid_map = @@ -66,7 +62,7 @@ let fresh_regions_with_substs (region_vars : T.region_var list) match r with T.Static -> T.Static | T.Var id -> T.Var (rid_subst id) in (* Return *) - (ctx, fresh_region_ids, rid_subst, rsubst) + (fresh_region_ids, rid_subst, rsubst) (** Erase the regions in a type and substitute the type variables *) let erase_regions_substitute_types (tsubst : T.TypeVarId.id -> T.ety) -- cgit v1.2.3 From 1d0254f555e26968badf05d605cd630c018dcaa8 Mon Sep 17 00:00:00 2001 From: Son Ho Date: Thu, 6 Jan 2022 18:25:09 +0100 Subject: Cleanup --- src/Contexts.ml | 4 ++-- src/Interpreter.ml | 1 - src/InterpreterBorrows.ml | 3 +-- src/InterpreterBorrowsCore.ml | 1 - src/InterpreterExpansion.ml | 3 +-- src/InterpreterProjectors.ml | 7 ++----- src/InterpreterUtils.ml | 4 +--- src/Synthesis.ml | 2 +- 8 files changed, 8 insertions(+), 17 deletions(-) (limited to 'src') diff --git a/src/Contexts.ml b/src/Contexts.ml index f8a7b56b..0fe3a09a 100644 --- a/src/Contexts.ml +++ b/src/Contexts.ml @@ -27,8 +27,8 @@ let abstraction_id_counter, fresh_abstraction_id = AbstractionId.fresh_stateful_generator () (** We shouldn't need to reset the global counters, but it might be good to - to it from time to time, every time we evaluate/synthesize a function for - instance. + do it from time to time, for instance every time we start evaluating/ + synthesizing a function. The reasons are manifold: - it might prevent the counters from overflowing (although this seems diff --git a/src/Interpreter.ml b/src/Interpreter.ml index ec15093d..2789517e 100644 --- a/src/Interpreter.ml +++ b/src/Interpreter.ml @@ -1,4 +1,3 @@ -open Errors module L = Logging module T = Types module A = CfimAst diff --git a/src/InterpreterBorrows.ml b/src/InterpreterBorrows.ml index a18ccefb..1dd4d247 100644 --- a/src/InterpreterBorrows.ml +++ b/src/InterpreterBorrows.ml @@ -3,7 +3,6 @@ module V = Values module C = Contexts module Subst = Substitute module L = Logging -open Utils open ValuesUtils open TypesUtils open InterpreterUtils @@ -226,7 +225,7 @@ let give_back_value (config : C.config) (bid : V.BorrowId.id) (* We sometimes need to reborrow values while giving a value back due: prepare that *) let allow_reborrows = true in let fresh_reborrow, apply_registered_reborrows = - prepare_reborrows config allow_reborrows ctx + prepare_reborrows config allow_reborrows in (* The visitor to give back the values *) let obj = diff --git a/src/InterpreterBorrowsCore.ml b/src/InterpreterBorrowsCore.ml index 6e09c90c..bc2f5971 100644 --- a/src/InterpreterBorrowsCore.ml +++ b/src/InterpreterBorrowsCore.ml @@ -7,7 +7,6 @@ module V = Values module C = Contexts module Subst = Substitute module L = Logging -open Utils open InterpreterUtils (** TODO: cleanup this a bit, once we have a better understanding about diff --git a/src/InterpreterExpansion.ml b/src/InterpreterExpansion.ml index 2de06f24..345c3df3 100644 --- a/src/InterpreterExpansion.ml +++ b/src/InterpreterExpansion.ml @@ -10,7 +10,6 @@ module C = Contexts module Subst = Substitute module L = Logging open TypesUtils -open ValuesUtils module Inv = Invariants module S = Synthesis open InterpreterUtils @@ -54,7 +53,7 @@ let apply_symbolic_expansion_to_target_avalues (config : C.config) let check_symbolic_no_ended = false in (* Prepare reborrows registration *) let fresh_reborrow, apply_registered_reborrows = - prepare_reborrows config allow_reborrows ctx + prepare_reborrows config allow_reborrows in (* Visitor to apply the expansion *) let obj = diff --git a/src/InterpreterProjectors.ml b/src/InterpreterProjectors.ml index 3fa824ab..036082eb 100644 --- a/src/InterpreterProjectors.ml +++ b/src/InterpreterProjectors.ml @@ -5,8 +5,6 @@ module C = Contexts module Subst = Substitute module L = Logging open TypesUtils -open ValuesUtils -open Utils open InterpreterUtils open InterpreterBorrowsCore @@ -471,8 +469,7 @@ let apply_reborrows (reborrows : (V.BorrowId.id * V.BorrowId.id) list) - a function to apply the reborrows in a context Those functions are of course stateful. *) -let prepare_reborrows (config : C.config) (allow_reborrows : bool) - (ctx : C.eval_ctx) : +let prepare_reborrows (config : C.config) (allow_reborrows : bool) : (V.BorrowId.id -> V.BorrowId.id) * (C.eval_ctx -> C.eval_ctx) = let reborrows : (V.BorrowId.id * V.BorrowId.id) list ref = ref [] in (* The function to generate and register fresh reborrows *) @@ -502,7 +499,7 @@ let apply_proj_borrows_on_input_value (config : C.config) (ctx : C.eval_ctx) let allow_reborrows = true in (* Prepare the reborrows *) let fresh_reborrow, apply_registered_reborrows = - prepare_reborrows config allow_reborrows ctx + prepare_reborrows config allow_reborrows in (* Apply the projector *) let av = diff --git a/src/InterpreterUtils.ml b/src/InterpreterUtils.ml index 40ef0d05..5f86fec2 100644 --- a/src/InterpreterUtils.ml +++ b/src/InterpreterUtils.ml @@ -6,10 +6,8 @@ module E = Expressions module C = Contexts module Subst = Substitute module A = CfimAst -module L = Logging -open TypesUtils -open ValuesUtils open Utils +open TypesUtils (** Some utilities *) diff --git a/src/Synthesis.ml b/src/Synthesis.ml index 79fa4065..b0ecd554 100644 --- a/src/Synthesis.ml +++ b/src/Synthesis.ml @@ -71,4 +71,4 @@ let synthesize_function_call (_fid : A.fun_id) let synthesize_panic () : unit = () -let synthesize_assert (v : V.typed_value) : unit = () +let synthesize_assert (_v : V.typed_value) : unit = () -- cgit v1.2.3 From a310c6036568d8f62e09804c67064686d106afd4 Mon Sep 17 00:00:00 2001 From: Son Ho Date: Thu, 6 Jan 2022 18:54:57 +0100 Subject: Add debugging info --- src/Invariants.ml | 30 +++++++++++++++++++++++++++--- 1 file changed, 27 insertions(+), 3 deletions(-) (limited to 'src') diff --git a/src/Invariants.ml b/src/Invariants.ml index 86fa3d46..e214e820 100644 --- a/src/Invariants.ml +++ b/src/Invariants.ml @@ -35,6 +35,17 @@ let set_outer_mut (info : outer_borrow_info) : outer_borrow_info = let set_outer_shared (_info : outer_borrow_info) : outer_borrow_info = { outer_borrow = true; outer_shared = true } +(* TODO: we need to factorize print functions for strings *) +let ids_reprs_to_string (reprs : V.BorrowId.id V.BorrowId.Map.t) : string = + let bindings = V.BorrowId.Map.bindings reprs in + let bindings = + List.map + (fun (id, repr_id) -> + V.BorrowId.to_string id ^ " -> " ^ V.BorrowId.to_string repr_id) + bindings + in + String.concat "\n" bindings + let borrows_infos_to_string (infos : borrow_info V.BorrowId.Map.t) : string = let bindings = V.BorrowId.Map.bindings infos in let bindings = List.map (fun (_, info) -> show_borrow_info info) bindings in @@ -160,10 +171,23 @@ let check_loans_borrows_relation_invariant (ctx : C.eval_ctx) : unit = (* Some utilities to register the borrows *) let find_info (bid : V.BorrowId.id) : borrow_info = (* Find the representant *) - let repr_bid = V.BorrowId.Map.find bid !ids_reprs in - (* Lookup the info *) - V.BorrowId.Map.find repr_bid !borrows_infos + match V.BorrowId.Map.find_opt bid !ids_reprs with + | Some repr_bid -> + (* Lookup the info *) + V.BorrowId.Map.find repr_bid !borrows_infos + | None -> + let err = + "find_info: could not find the representant of borrow " + ^ V.BorrowId.to_string bid ^ "\n" ^ "\n- Context:\n" + ^ eval_ctx_to_string ctx ^ "\n- representants:\n" + ^ ids_reprs_to_string !ids_reprs + ^ "\n- info:\n" + ^ borrows_infos_to_string !borrows_infos + in + L.log#serror err; + failwith err in + let update_info (bid : V.BorrowId.id) (info : borrow_info) : unit = (* Find the representant *) let repr_bid = V.BorrowId.Map.find bid !ids_reprs in -- cgit v1.2.3