path: root/compiler/InterpreterProjectors.ml

open Types
open Values
open Contexts
module Subst = Substitute
module Assoc = AssociatedTypes
open TypesUtils
open InterpreterUtils
open InterpreterBorrowsCore
open Errors

(** The local logger *)
let log = Logging.projectors_log

(** [ty] shouldn't contain erased regions *)
let rec apply_proj_borrows_on_shared_borrow (meta : Meta.meta) (ctx : eval_ctx)
    (fresh_reborrow : BorrowId.id -> BorrowId.id) (regions : RegionId.Set.t)
    (v : typed_value) (ty : rty) : abstract_shared_borrows =
  (* Sanity check - TODO: move those elsewhere (here we perform the check at every
   * recursive call which is a bit overkill...) *)
  let ety = Subst.erase_regions ty in
  sanity_check (ty_is_rty ty && ety = v.ty) meta;
  (* Project - if there are no regions from the abstraction in the type, return [_] *)
  if not (ty_has_regions_in_set regions ty) then []
  else
    match (v.value, ty) with
    | VLiteral _, TLiteral _ -> []
    | VAdt adt, TAdt (id, generics) ->
        (* Retrieve the types of the fields *)
        let field_types =
          Assoc.ctx_adt_value_get_inst_norm_field_rtypes meta ctx adt id generics
        in

        (* Project over the field values *)
        let fields_types = List.combine adt.field_values field_types in
        let proj_fields =
          List.map
            (fun (fv, fty) ->
              apply_proj_borrows_on_shared_borrow meta ctx fresh_reborrow regions fv
                fty)
            fields_types
        in
        List.concat proj_fields
    | VBottom, _ -> craise meta "Unreachable"
    | VBorrow bc, TRef (r, ref_ty, kind) ->
        (* Retrieve the bid of the borrow and the asb of the projected borrowed value *)
        let bid, asb =
          (* Not in the set: dive *)
          match (bc, kind) with
          | VMutBorrow (bid, bv), RMut ->
              (* Apply the projection on the borrowed value *)
              let asb =
                apply_proj_borrows_on_shared_borrow meta ctx fresh_reborrow regions
                  bv ref_ty
              in
              (bid, asb)
          | VSharedBorrow bid, RShared ->
              (* Lookup the shared value *)
              let ek = ek_all in
              let sv = lookup_loan meta ek bid ctx in
              let asb =
                match sv with
                | _, Concrete (VSharedLoan (_, sv))
                | _, Abstract (ASharedLoan (_, sv, _)) ->
                    apply_proj_borrows_on_shared_borrow meta ctx fresh_reborrow
                      regions sv ref_ty
                | _ -> craise meta "Unexpected"
              in
              (bid, asb)
          | VReservedMutBorrow _, _ ->
              craise
                meta
                   "Can't apply a proj_borrow over a reserved mutable borrow"
          | _ -> craise meta "Unreachable"
        in
        let asb =
          (* Check if the region is in the set of projected regions (note that
           * we never project over static regions) *)
          if region_in_set r regions then
            let bid' = fresh_reborrow bid in
            AsbBorrow bid' :: asb
          else asb
        in
        asb
    | VLoan _, _ -> craise meta "Unreachable"
    | VSymbolic s, _ ->
        (* Check that the projection doesn't contain ended regions *)
        sanity_check (not (projections_intersect meta s.sv_ty ctx.ended_regions ty regions)) meta;
        [ AsbProjReborrows (s, ty) ]
    | _ -> craise meta "Unreachable"

let rec apply_proj_borrows (meta : Meta.meta) (check_symbolic_no_ended : bool) (ctx : eval_ctx)
    (fresh_reborrow : BorrowId.id -> BorrowId.id) (regions : RegionId.Set.t)
    (ancestors_regions : RegionId.Set.t) (v : typed_value) (ty : rty) :
    typed_avalue =
  (* Sanity check - TODO: move this elsewhere (here we perform the check at every
   * recursive call which is a bit overkill...) *)
  let ety = Substitute.erase_regions ty in
  sanity_check (ty_is_rty ty && ety = v.ty) meta;
  (* Project - if there are no regions from the abstraction in the type, return [_] *)
  if not (ty_has_regions_in_set regions ty) then { value = AIgnored; ty }
  else
    let value : avalue =
      match (v.value, ty) with
      | VLiteral _, TLiteral _ -> AIgnored
      | VAdt adt, TAdt (id, generics) ->
          (* Retrieve the types of the fields *)
          let field_types =
            Assoc.ctx_adt_value_get_inst_norm_field_rtypes meta ctx adt id generics
          in
          (* Project over the field values *)
          let fields_types = List.combine adt.field_values field_types in
          let proj_fields =
            List.map
              (fun (fv, fty) ->
                apply_proj_borrows meta check_symbolic_no_ended ctx fresh_reborrow
                  regions ancestors_regions fv fty)
              fields_types
          in
          AAdt { variant_id = adt.variant_id; field_values = proj_fields }
      | VBottom, _ -> craise meta "Unreachable"
      | VBorrow bc, TRef (r, ref_ty, kind) ->
          if
            (* Check if the region is in the set of projected regions (note that
             * we never project over static regions) *)
            region_in_set r regions
          then
            (* In the set *)
            let bc =
              match (bc, kind) with
              | VMutBorrow (bid, bv), RMut ->
                  (* Apply the projection on the borrowed value *)
                  let bv =
                    apply_proj_borrows meta check_symbolic_no_ended ctx
                      fresh_reborrow regions ancestors_regions bv ref_ty
                  in
                  AMutBorrow (bid, bv)
              | VSharedBorrow bid, RShared ->
                  (* Rem.: we don't need to also apply the projection on the
                     borrowed value, because for as long as the abstraction
                     lives then the shared borrow lives, which means that the
                     whole value is borrowed (and thus immutable).
                     This is not the case if the current borrow is not to be
                     projected to the current abstraction: if this happens,
                     then maybe there are borrows *inside* the shared value
                     which belong to the current abstraction, meaning we
                     need to lookup the shared value and project it (see the
                     other branch of the [if then else]).
                  *)
                  ASharedBorrow bid
              | VReservedMutBorrow _, _ ->
                  craise
                    meta
                       "Can't apply a proj_borrow over a reserved mutable \
                        borrow"
              | _ -> craise meta "Unreachable"
            in
            ABorrow bc
          else
            (* Not in the set: ignore the borrow, but project the borrowed
               value (maybe some borrows *inside* the borrowed value are in
               the region set) *)
            let bc =
              match (bc, kind) with
              | VMutBorrow (bid, bv), RMut ->
                  (* Apply the projection on the borrowed value *)
                  let bv =
                    apply_proj_borrows meta check_symbolic_no_ended ctx
                      fresh_reborrow regions ancestors_regions bv ref_ty
                  in
                  (* If the borrow id is in the ancestor's regions, we still need
                   * to remember it *)
                  let opt_bid =
                    if region_in_set r ancestors_regions then Some bid else None
                  in
                  (* Return *)
                  AIgnoredMutBorrow (opt_bid, bv)
              | VSharedBorrow bid, RShared ->
                  (* Lookup the shared value *)
                  let ek = ek_all in
                  let sv = lookup_loan meta ek bid ctx in
                  let asb =
                    match sv with
                    | _, Concrete (VSharedLoan (_, sv))
                    | _, Abstract (ASharedLoan (_, sv, _)) ->
                        apply_proj_borrows_on_shared_borrow meta ctx fresh_reborrow
                          regions sv ref_ty
                    | _ -> craise meta "Unexpected"
                  in
                  AProjSharedBorrow asb
              | VReservedMutBorrow _, _ ->
                  craise
                    meta
                       "Can't apply a proj_borrow over a reserved mutable \
                        borrow"
              | _ -> craise meta "Unreachable"
            in
            ABorrow bc
      | VLoan _, _ -> craise meta "Unreachable"
      | VSymbolic s, _ ->
          (* Check that the projection doesn't contain already ended regions,
           * if necessary *)
          if check_symbolic_no_ended then (
            let ty1 = s.sv_ty in
            let rset1 = ctx.ended_regions in
            let ty2 = ty in
            let rset2 = regions in
            log#ldebug
              (lazy
                ("projections_intersect:" ^ "\n- ty1: " ^ ty_to_string ctx ty1
               ^ "\n- rset1: "
                ^ RegionId.Set.to_string None rset1
                ^ "\n- ty2: " ^ ty_to_string ctx ty2 ^ "\n- rset2: "
                ^ RegionId.Set.to_string None rset2
                ^ "\n"));
            sanity_check (not (projections_intersect meta ty1 rset1 ty2 rset2))) meta;
          ASymbolic (AProjBorrows (s, ty))
      | _ ->
          log#lerror
            (lazy
              ("apply_proj_borrows: unexpected inputs:\n- input value: "
              ^ typed_value_to_string ~meta:(Some meta) ctx v
              ^ "\n- proj rty: " ^ ty_to_string ctx ty));
          craise meta "Unreachable"
    in
    { value; ty }

let symbolic_expansion_non_borrow_to_value (meta : Meta.meta) (sv : symbolic_value)
    (see : symbolic_expansion) : typed_value =
  let ty = Subst.erase_regions sv.sv_ty in
  let value =
    match see with
    | SeLiteral cv -> VLiteral cv
    | SeAdt (variant_id, field_values) ->
        let field_values =
          List.map mk_typed_value_from_symbolic_value field_values
        in
        VAdt { variant_id; field_values }
    | SeMutRef (_, _) | SeSharedRef (_, _) ->
        craise meta "Unexpected symbolic reference expansion"
  in
  { value; ty }

let symbolic_expansion_non_shared_borrow_to_value (meta : Meta.meta) (sv : symbolic_value)
    (see : symbolic_expansion) : typed_value =
  match see with
  | SeMutRef (bid, bv) ->
      let ty = Subst.erase_regions sv.sv_ty in
      let bv = mk_typed_value_from_symbolic_value bv in
      let value = VBorrow (VMutBorrow (bid, bv)) in
      { value; ty }
  | SeSharedRef (_, _) ->
      craise meta "Unexpected symbolic shared reference expansion"
  | _ -> symbolic_expansion_non_borrow_to_value meta sv see

(** Apply (and reduce) a projector over loans to a value.

    TODO: detailed comments. See [apply_proj_borrows]
*)
let apply_proj_loans_on_symbolic_expansion (meta : Meta.meta) (regions : RegionId.Set.t)
    (ancestors_regions : RegionId.Set.t) (see : symbolic_expansion)
    (original_sv_ty : rty) : typed_avalue =
  (* Sanity check: if we have a proj_loans over a symbolic value, it should
   * contain regions which we will project *)
  sanity_check (ty_has_regions_in_set regions original_sv_ty) meta;
  (* Match *)
  let (value, ty) : avalue * ty =
    match (see, original_sv_ty) with
    | SeLiteral _, TLiteral _ -> (AIgnored, original_sv_ty)
    | SeAdt (variant_id, field_values), TAdt (_id, _generics) ->
        (* Project over the field values *)
        let field_values =
          List.map
            (mk_aproj_loans_value_from_symbolic_value regions)
            field_values
        in
        (AAdt { variant_id; field_values }, original_sv_ty)
    | SeMutRef (bid, spc), TRef (r, ref_ty, RMut) ->
        (* Sanity check *)
        sanity_check (spc.sv_ty = ref_ty) meta;
        (* Apply the projector to the borrowed value *)
        let child_av = mk_aproj_loans_value_from_symbolic_value regions spc in
        (* Check if the region is in the set of projected regions (note that
         * we never project over static regions) *)
        if region_in_set r regions then
          (* In the set: keep *)
          (ALoan (AMutLoan (bid, child_av)), ref_ty)
        else
          (* Not in the set: ignore *)
          (* If the borrow id is in the ancestor's regions, we still need
           * to remember it *)
          let opt_bid =
            if region_in_set r ancestors_regions then Some bid else None
          in
          (ALoan (AIgnoredMutLoan (opt_bid, child_av)), ref_ty)
    | SeSharedRef (bids, spc), TRef (r, ref_ty, RShared) ->
        (* Sanity check *)
        sanity_check (spc.sv_ty = ref_ty) meta;
        (* Apply the projector to the borrowed value *)
        let child_av = mk_aproj_loans_value_from_symbolic_value regions spc in
        (* Check if the region is in the set of projected regions (note that
         * we never project over static regions) *)
        if region_in_set r regions then
          (* In the set: keep *)
          let shared_value = mk_typed_value_from_symbolic_value spc in
          (ALoan (ASharedLoan (bids, shared_value, child_av)), ref_ty)
        else
          (* Not in the set: ignore *)
          (ALoan (AIgnoredSharedLoan child_av), ref_ty)
    | _ -> craise meta "Unreachable"
  in
  { value; ty }

(** Auxiliary function. See [give_back_value].

    Apply reborrows to a context.

    The [reborrows] input is a list of pairs (shared loan id, id to insert
    in the shared loan).
    This function is used when applying projectors on shared borrows: when
    doing so, we might need to reborrow subvalues from the shared value.
    For instance:
    {[
      fn f<'a,'b,'c>(x : &'a 'b 'c u32)
    ]}
    When introducing the abstractions for 'a, 'b and 'c, we apply a projector
    on some value [shared_borrow l : &'a &'b &'c u32].
    In the 'a abstraction, this shared borrow gets projected. However, when
    reducing the projectors for the 'b and 'c abstractions, we need to make
    sure that the borrows living in regions 'b and 'c live as long as those
    regions. This is done by looking up the shared value and applying reborrows
    on the borrows we find there (note that those reborrows apply on shared
    borrows - easy - and mutable borrows - in this case, we reborrow the whole
    borrow: [mut_borrow ... ~~> shared_loan {...} (mut_borrow ...)]).
*)
let apply_reborrows (meta : Meta.meta) (reborrows : (BorrowId.id * BorrowId.id) list)
    (ctx : eval_ctx) : eval_ctx =
  (* This is a bit brutal, but whenever we insert a reborrow, we remove
   * it from the list. This allows us to check that all the reborrows were
   * applied before returning.
   * We might reimplement that in a more efficient manner by using maps. *)
  let reborrows = ref reborrows in

  (* Check if a value is a mutable borrow, and return its identifier if
     it is the case *)
  let get_borrow_in_mut_borrow (v : typed_value) : BorrowId.id option =
    match v.value with
    | VBorrow lc -> (
        match lc with
        | VSharedBorrow _ | VReservedMutBorrow _ -> None
        | VMutBorrow (id, _) -> Some id)
    | _ -> None
  in

  (* Add the proper reborrows to a set of borrow ids (for a shared loan) *)
  let insert_reborrows bids =
    (* Find the reborrows to apply *)
    let insert, reborrows' =
      List.partition (fun (bid, _) -> BorrowId.Set.mem bid bids) !reborrows
    in
    reborrows := reborrows';
    let insert = List.map snd insert in
    (* Insert the borrows *)
    List.fold_left (fun bids bid -> BorrowId.Set.add bid bids) bids insert
  in

  (* Get the list of reborrows for a given borrow id *)
  let get_reborrows_for_bid bid =
    (* Find the reborrows to apply *)
    let insert, reborrows' =
      List.partition (fun (bid', _) -> bid' = bid) !reborrows
    in
    reborrows := reborrows';
    List.map snd insert
  in

  let borrows_to_set bids =
    List.fold_left
      (fun bids bid -> BorrowId.Set.add bid bids)
      BorrowId.Set.empty bids
  in

  (* Insert reborrows for a given borrow id into a given set of borrows *)
  let insert_reborrows_for_bid bids bid =
    (* Find the reborrows to apply *)
    let insert = get_reborrows_for_bid bid in
    (* Insert the borrows *)
    List.fold_left (fun bids bid -> BorrowId.Set.add bid bids) bids insert
  in

  let obj =
    object
      inherit [_] map_eval_ctx as super

      (** We may need to reborrow mutable borrows. Note that this doesn't
          happen for aborrows *)
      method! visit_typed_value env v =
        match v.value with
        | VBorrow (VMutBorrow (bid, bv)) ->
            let insert = get_reborrows_for_bid bid in
            let nbc = super#visit_VMutBorrow env bid bv in
            let nbc = { v with value = VBorrow nbc } in
            if insert = [] then (* No reborrows: do nothing special *)
              nbc
            else
              (* There are reborrows: insert a shared loan *)
              let insert = borrows_to_set insert in
              let value = VLoan (VSharedLoan (insert, nbc)) in
              let ty = v.ty in
              { value; ty }
        | _ -> super#visit_typed_value env v

      (** We reimplement {!visit_loan_content} (rather than one of the sub-
          functions) on purpose: exhaustive matches are good for maintenance *)
      method! visit_loan_content env lc =
        match lc with
        | VSharedLoan (bids, sv) ->
            (* Insert the reborrows *)
            let bids = insert_reborrows bids in
            (* Check if the contained value is a mutable borrow, in which
             * case we might need to reborrow it by adding more borrow ids
             * to the current set of borrows - by doing this small
             * manipulation here, we accumulate the borrow ids in the same
             * shared loan, right above the mutable borrow, and avoid
             * stacking shared loans (note that doing this is not a problem
             * from a soundness point of view, but it is a bit ugly...) *)
            let bids =
              match get_borrow_in_mut_borrow sv with
              | None -> bids
              | Some bid -> insert_reborrows_for_bid bids bid
            in
            (* Update and explore *)
            super#visit_VSharedLoan env bids sv
        | VMutLoan bid ->
            (* Nothing special to do *)
            super#visit_VMutLoan env bid

      method! visit_aloan_content env lc =
        match lc with
        | ASharedLoan (bids, sv, av) ->
            (* Insert the reborrows *)
            let bids = insert_reborrows bids in
            (* Similarly to the non-abstraction case: check if the shared
             * value is a mutable borrow, to eventually insert more reborrows *)
            (* Update and explore *)
            let bids =
              match get_borrow_in_mut_borrow sv with
              | None -> bids
              | Some bid -> insert_reborrows_for_bid bids bid
            in
            (* Update and explore *)
            super#visit_ASharedLoan env bids sv av
        | AIgnoredSharedLoan _
        | AMutLoan (_, _)
        | AEndedMutLoan { given_back = _; child = _; given_back_meta = _ }
        | AEndedSharedLoan (_, _)
        | AIgnoredMutLoan (_, _)
        | AEndedIgnoredMutLoan
            { given_back = _; child = _; given_back_meta = _ } ->
            (* Nothing particular to do *)
            super#visit_aloan_content env lc
    end
  in

  (* Visit *)
  let ctx = obj#visit_eval_ctx () ctx in
  (* Check that there are no reborrows remaining *)
  sanity_check (!reborrows = []) meta;
  (* Return *)
  ctx

let prepare_reborrows (config : config) (meta : Meta.meta) (allow_reborrows : bool) :
    (BorrowId.id -> BorrowId.id) * (eval_ctx -> eval_ctx) =
  let reborrows : (BorrowId.id * BorrowId.id) list ref = ref [] in
  (* The function to generate and register fresh reborrows *)
  let fresh_reborrow (bid : BorrowId.id) : BorrowId.id =
    if allow_reborrows then (
      let bid' = fresh_borrow_id () in
      reborrows := (bid, bid') :: !reborrows;
      bid')
    else craise meta "Unexpected reborrow"
  in
  (* The function to apply the reborrows in a context *)
  let apply_registered_reborrows (ctx : eval_ctx) : eval_ctx =
    match config.mode with
    | ConcreteMode ->
        sanity_check (!reborrows = []) meta;
        ctx
    | SymbolicMode ->
        (* Apply the reborrows *)
        apply_reborrows meta !reborrows ctx
  in
  (fresh_reborrow, apply_registered_reborrows)

(** [ty] shouldn't have erased regions *)
let apply_proj_borrows_on_input_value (config : config) (meta : Meta.meta) (ctx : eval_ctx)
    (regions : RegionId.Set.t) (ancestors_regions : RegionId.Set.t)
    (v : typed_value) (ty : rty) : eval_ctx * typed_avalue =
  cassert (ty_is_rty ty) meta "TODO: error message";
  let check_symbolic_no_ended = true in
  let allow_reborrows = true in
  (* Prepare the reborrows *)
  let fresh_reborrow, apply_registered_reborrows =
    prepare_reborrows config meta allow_reborrows
  in
  (* Apply the projector *)
  let av =
    apply_proj_borrows meta check_symbolic_no_ended ctx fresh_reborrow regions
      ancestors_regions v ty
  in
  (* Apply the reborrows *)
  let ctx = apply_registered_reborrows ctx in
  (* Return *)
  (ctx, av)