open Types open TypesUtils open Expressions open Values open LlbcAst open SymbolicAst open Errors let mk_mplace (meta : Meta.meta) (p : place) (ctx : Contexts.eval_ctx) : mplace = let bv = Contexts.ctx_lookup_var_binder meta ctx p.var_id in { bv; projection = p.projection } let mk_opt_mplace (meta : Meta.meta) (p : place option) (ctx : Contexts.eval_ctx) : mplace option = Option.map (fun p -> mk_mplace meta p ctx) p let mk_opt_place_from_op (meta : Meta.meta) (op : operand) (ctx : Contexts.eval_ctx) : mplace option = match op with Copy p | Move p -> Some (mk_mplace meta p ctx) | Constant _ -> None let mk_emeta (m : emeta) (e : expression) : expression = Meta (m, e) let synthesize_symbolic_expansion (meta : Meta.meta) (sv : symbolic_value) (place : mplace option) (seel : symbolic_expansion option list) (el : expression list option) : expression option = match el with | None -> None | Some el -> let ls = List.combine seel el in (* Match on the symbolic value type to know which can of expansion happened *) let expansion = match sv.sv_ty with | TLiteral TBool -> ( (* Boolean expansion: there should be two branches *) match ls with | [ (Some (SeLiteral (VBool true)), true_exp); (Some (SeLiteral (VBool false)), false_exp); ] -> ExpandBool (true_exp, false_exp) | _ -> craise meta "Ill-formed boolean expansion") | TLiteral (TInteger int_ty) -> (* Switch over an integer: split between the "regular" branches and the "otherwise" branch (which should be the last branch) *) let branches, otherwise = Collections.List.pop_last ls in (* For all the regular branches, the symbolic value should have * been expanded to a constant *) let get_scalar (see : symbolic_expansion option) : scalar_value = match see with | Some (SeLiteral (VScalar cv)) -> sanity_check (cv.int_ty = int_ty) meta; cv | _ -> craise meta "Unreachable" in let branches = List.map (fun (see, exp) -> (get_scalar see, exp)) branches in (* For the otherwise branch, the symbolic value should have been left * unchanged *) let otherwise_see, otherwise = otherwise in sanity_check (otherwise_see = None) meta; (* Return *) ExpandInt (int_ty, branches, otherwise) | TAdt (_, _) -> (* Branching: it is necessarily an enumeration expansion *) let get_variant (see : symbolic_expansion option) : VariantId.id option * symbolic_value list = match see with | Some (SeAdt (vid, fields)) -> (vid, fields) | _ -> craise meta "Ill-formed branching ADT expansion" in let exp = List.map (fun (see, exp) -> let vid, fields = get_variant see in (vid, fields, exp)) ls in ExpandAdt exp | TRef (_, _, _) -> ( (* Reference expansion: there should be one branch *) match ls with | [ (Some see, exp) ] -> ExpandNoBranch (see, exp) | _ -> craise meta "Ill-formed borrow expansion") | TVar _ | TLiteral TChar | TNever | TTraitType _ | TArrow _ | TRawPtr _ -> craise meta "Ill-formed symbolic expansion" in Some (Expansion (place, sv, expansion)) let synthesize_symbolic_expansion_no_branching (meta : Meta.meta) (sv : symbolic_value) (place : mplace option) (see : symbolic_expansion) (e : expression option) : expression option = let el = Option.map (fun e -> [ e ]) e in synthesize_symbolic_expansion meta sv place [ Some see ] el let synthesize_function_call (call_id : call_id) (ctx : Contexts.eval_ctx) (sg : fun_sig option) (regions_hierarchy : region_var_groups) (abstractions : AbstractionId.id list) (generics : generic_args) (trait_method_generics : (generic_args * trait_instance_id) option) (args : typed_value list) (args_places : mplace option list) (dest : symbolic_value) (dest_place : mplace option) (e : expression option) : expression option = Option.map (fun e -> let call = { call_id; ctx; sg; regions_hierarchy; abstractions; generics; trait_method_generics; args; dest; args_places; dest_place; } in FunCall (call, e)) e let synthesize_global_eval (gid : GlobalDeclId.id) (generics : generic_args) (dest : symbolic_value) (e : expression option) : expression option = Option.map (fun e -> EvalGlobal (gid, generics, dest, e)) e let synthesize_regular_function_call (fun_id : fun_id_or_trait_method_ref) (call_id : FunCallId.id) (ctx : Contexts.eval_ctx) (sg : fun_sig) (regions_hierarchy : region_var_groups) (abstractions : AbstractionId.id list) (generics : generic_args) (trait_method_generics : (generic_args * trait_instance_id) option) (args : typed_value list) (args_places : mplace option list) (dest : symbolic_value) (dest_place : mplace option) (e : expression option) : expression option = synthesize_function_call (Fun (fun_id, call_id)) ctx (Some sg) regions_hierarchy abstractions generics trait_method_generics args args_places dest dest_place e let synthesize_unary_op (ctx : Contexts.eval_ctx) (unop : unop) (arg : typed_value) (arg_place : mplace option) (dest : symbolic_value) (dest_place : mplace option) (e : expression option) : expression option = let generics = empty_generic_args in synthesize_function_call (Unop unop) ctx None [] [] generics None [ arg ] [ arg_place ] dest dest_place e let synthesize_binary_op (ctx : Contexts.eval_ctx) (binop : binop) (arg0 : typed_value) (arg0_place : mplace option) (arg1 : typed_value) (arg1_place : mplace option) (dest : symbolic_value) (dest_place : mplace option) (e : expression option) : expression option = let generics = empty_generic_args in synthesize_function_call (Binop binop) ctx None [] [] generics None [ arg0; arg1 ] [ arg0_place; arg1_place ] dest dest_place e let synthesize_end_abstraction (ctx : Contexts.eval_ctx) (abs : abs) (e : expression option) : expression option = Option.map (fun e -> EndAbstraction (ctx, abs, e)) e let synthesize_assignment (ctx : Contexts.eval_ctx) (lplace : mplace) (rvalue : typed_value) (rplace : mplace option) (e : expression option) : expression option = Option.map (fun e -> Meta (Assignment (ctx, lplace, rvalue, rplace), e)) e let synthesize_assertion (ctx : Contexts.eval_ctx) (v : typed_value) (e : expression option) = Option.map (fun e -> Assertion (ctx, v, e)) e let synthesize_forward_end (ctx : Contexts.eval_ctx) (loop_input_values : typed_value SymbolicValueId.Map.t option) (e : expression) (el : expression RegionGroupId.Map.t) = Some (ForwardEnd (ctx, loop_input_values, e, el)) let synthesize_loop (loop_id : LoopId.id) (input_svalues : symbolic_value list) (fresh_svalues : SymbolicValueId.Set.t) (rg_to_given_back_tys : ty list RegionGroupId.Map.t) (end_expr : expression option) (loop_expr : expression option) (meta : Meta.meta) : expression option = match (end_expr, loop_expr) with | None, None -> None | Some end_expr, Some loop_expr -> Some (Loop { loop_id; input_svalues; fresh_svalues; rg_to_given_back_tys; end_expr; loop_expr; meta; }) | _ -> craise meta "Unreachable" let save_snapshot (ctx : Contexts.eval_ctx) (e : expression option) : expression option = match e with None -> None | Some e -> Some (Meta (Snapshot ctx, e)) let cf_save_snapshot : Cps.cm_fun = fun cf ctx -> save_snapshot ctx (cf ctx)