summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorSon Ho2022-01-06 10:41:24 +0100
committerSon Ho2022-01-06 10:41:24 +0100
commitea2d6637cfd9f6e17d1b411fb03e9f6c50edc331 (patch)
tree32e26f0933189de8d0d7a3412c61f5dcef864ab3
parent70c6cbda0899bbf8783efcf55db02f74cffb4754 (diff)
Move some definitions from Interpreter to InterpreterStatements
Diffstat (limited to '')
-rw-r--r--src/Interpreter.ml895
-rw-r--r--src/InterpreterStatements.ml894
2 files changed, 895 insertions, 894 deletions
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<ty>
- - 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<T>`
- 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<T> -> &'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<ty>
+ - 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<T>`
+ 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<T> -> &'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