summaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
authorSon Ho2022-01-04 22:42:26 +0100
committerSon Ho2022-01-04 22:42:26 +0100
commit90bbb47dea8ae6626e8aad89e3d2606ea3508534 (patch)
tree0e7b796a6a97dc3305083058e89831bf3c83212b /src
parent02a1cd57fe3a36f042579a2d0e8c194e4d9a599a (diff)
Move some functions from Interpreter to InterpreterUtils
Diffstat (limited to 'src')
-rw-r--r--src/Interpreter.ml536
-rw-r--r--src/InterpreterUtils.ml536
2 files changed, 536 insertions, 536 deletions
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