summaryrefslogtreecommitdiff
path: root/compiler/SynthesizeSymbolic.ml
blob: ae701c330adc01b115cc1ea8375bbed5bc59a00e (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
open Types
open TypesUtils
open Expressions
open Values
open LlbcAst
open SymbolicAst
open Errors

let mk_mplace (span : Meta.span) (p : place) (ctx : Contexts.eval_ctx) : mplace
    =
  let bv = Contexts.ctx_lookup_var_binder span ctx p.var_id in
  { bv; projection = p.projection }

let mk_opt_mplace (span : Meta.span) (p : place option)
    (ctx : Contexts.eval_ctx) : mplace option =
  Option.map (fun p -> mk_mplace span p ctx) p

let mk_opt_place_from_op (span : Meta.span) (op : operand)
    (ctx : Contexts.eval_ctx) : mplace option =
  match op with
  | Copy p | Move p -> Some (mk_mplace span p ctx)
  | Constant _ -> None

let mk_espan (m : espan) (e : expression) : expression = Meta (m, e)

let synthesize_symbolic_expansion (span : Meta.span) (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 __FILE__ __LINE__ span "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 __FILE__ __LINE__ (cv.int_ty = int_ty) span;
                  cv
              | _ -> craise __FILE__ __LINE__ span "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 __FILE__ __LINE__ (otherwise_see = None) span;
            (* 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 __FILE__ __LINE__ span
                    "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 __FILE__ __LINE__ span "Ill-formed borrow expansion")
        | TVar _ | TLiteral TChar | TNever | TTraitType _ | TArrow _ | TRawPtr _
          ->
            craise __FILE__ __LINE__ span "Ill-formed symbolic expansion"
      in
      Some (Expansion (place, sv, expansion))

let synthesize_symbolic_expansion_no_branching (span : Meta.span)
    (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 span 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)
    (span : Meta.span) : 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;
             span;
           })
  | _ -> craise __FILE__ __LINE__ span "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))