infer_clone/sledge/src/fol/theory.ml

(*
 * Copyright (c) Facebook, Inc. and its affiliates.
 *
 * This source code is licensed under the MIT license found in the
 * LICENSE file in the root directory of this source tree.
 *)

(** Theory Solver *)

(* Theory equation solver state ===========================================*)

type oriented_equality = {var: Trm.t; rep: Trm.t}

type t =
  { wrt: Var.Set.t
  ; no_fresh: bool
  ; fresh: Var.Set.t
  ; solved: oriented_equality list option
  ; pending: (Trm.t * Trm.t) list }

let pp ppf = function
  | {solved= None} -> Format.fprintf ppf "unsat"
  | {solved= Some solved; fresh; pending} ->
      Format.fprintf ppf "%a%a : %a" Var.Set.pp_xs fresh
        (List.pp ";@ " (fun ppf {var; rep} ->
             Format.fprintf ppf "@[%a ↦ %a@]" Trm.pp var Trm.pp rep ))
        solved
        (List.pp ";@ " (fun ppf (a, b) ->
             Format.fprintf ppf "@[%a = %a@]" Trm.pp a Trm.pp b ))
        pending

(* Classification of terms ================================================*)

type kind = InterpApp | NonInterpAtom | InterpAtom | UninterpApp
[@@deriving compare, equal]

let classify e =
  match (e : Trm.t) with
  | Var _ -> NonInterpAtom
  | Z _ | Q _ -> InterpAtom
  | Arith a ->
      if Trm.Arith.is_uninterpreted a then UninterpApp
      else (
        assert (
          match Trm.Arith.classify a with
          | Trm _ | Const _ -> violates Trm.invariant e
          | Interpreted -> true
          | Uninterpreted -> false ) ;
        InterpApp )
  | Concat [||] -> InterpAtom
  | Splat _ | Sized _ | Extract _ | Concat _ -> InterpApp
  | Apply (_, [||]) -> NonInterpAtom
  | Apply _ -> UninterpApp

let is_interpreted e = equal_kind (classify e) InterpApp
let is_uninterpreted e = equal_kind (classify e) UninterpApp

let is_noninterpreted e =
  match classify e with
  | InterpAtom | InterpApp -> false
  | NonInterpAtom | UninterpApp -> true

let rec solvables e =
  match classify e with
  | InterpAtom -> Iter.empty
  | InterpApp -> solvable_trms e
  | NonInterpAtom | UninterpApp -> Iter.return e

and solvable_trms e = Iter.flat_map ~f:solvables (Trm.trms e)

let rec map_solvables e ~f =
  match classify e with
  | InterpAtom -> e
  | NonInterpAtom | UninterpApp -> f e
  | InterpApp -> Trm.map ~f:(map_solvables ~f) e

(* Solving equations ======================================================*)

(** prefer representative terms that are minimal in the order s.t. Var <
    Sized < Extract < Concat < others, then using height of sequence
    nesting, and then using Trm.compare *)
let prefer e f =
  let rank e =
    match (e : Trm.t) with
    | Var _ -> 0
    | Sized _ -> 1
    | Extract _ -> 2
    | Concat _ -> 3
    | _ -> 4
  in
  let o = compare (rank e) (rank f) in
  if o <> 0 then o
  else
    let o = compare (Trm.height e) (Trm.height f) in
    if o <> 0 then o else Trm.compare e f

(** orient equations based on representative preference *)
let orient e f =
  match Sign.of_int (prefer e f) with
  | Neg -> Some (e, f)
  | Zero -> None
  | Pos -> Some (f, e)

let add_solved ~var ~rep s =
  match s with
  | {solved= None} -> s
  | {solved= Some solved} -> {s with solved= Some ({var; rep} :: solved)}

let add_pending a b s = {s with pending= (a, b) :: s.pending}

let fresh name s =
  if s.no_fresh then None
  else
    let x, wrt = Var.fresh name ~wrt:s.wrt in
    let fresh = Var.Set.add x s.fresh in
    Some (Trm.var x, {s with wrt; fresh})

let solve_poly p q s =
  [%trace]
    ~call:(fun {pf} -> pf "@ %a = %a" Trm.pp p Trm.pp q)
    ~retn:(fun {pf} -> pf "%a" pp)
  @@ fun () ->
  match Trm.sub p q with
  | Z z -> if Z.equal Z.zero z then s else {s with solved= None}
  | Var _ as var -> add_solved ~var ~rep:Trm.zero s
  | p_q -> (
    match Trm.Arith.solve_zero_eq p_q with
    | Some (var, rep) ->
        add_solved ~var:(Trm.arith var) ~rep:(Trm.arith rep) s
    | None -> add_solved ~var:p_q ~rep:Trm.zero s )

(* α[o,l) = β ==> l = |β| ∧ α = (⟨n,c⟩[0,o) ^ β ^ ⟨n,c⟩[o+l,n-o-l)) where n
   = |α| and c fresh *)
let solve_extract a o l b s =
  [%trace]
    ~call:(fun {pf} ->
      pf "@ %a = %a" Trm.pp (Trm.extract ~seq:a ~off:o ~len:l) Trm.pp b )
    ~retn:(fun {pf} -> pf "%a" (Option.pp "%a" pp))
  @@ fun () ->
  let* c, s = fresh "c" s in
  let+ n, s =
    match Trm.seq_size a with Some n -> Some (n, s) | None -> fresh "n" s
  in
  let n_c = Trm.sized ~siz:n ~seq:c in
  let o_l = Trm.add o l in
  let n_o_l = Trm.sub n o_l in
  let c0 = Trm.extract ~seq:n_c ~off:Trm.zero ~len:o in
  let c1 = Trm.extract ~seq:n_c ~off:o_l ~len:n_o_l in
  let b, s =
    match Trm.seq_size b with
    | None -> (Trm.sized ~siz:l ~seq:b, s)
    | Some m -> (b, add_pending l m s)
  in
  add_pending a (Trm.concat [|c0; b; c1|]) s

(* α₀^…^αᵢ^αⱼ^…^αᵥ = β ==> |α₀^…^αᵥ| = |β| ∧ … ∧ αⱼ = β[n₀+…+nᵢ,nⱼ) ∧ …
   where nₓ ≡ |αₓ| and m = |β| *)
let solve_concat a0V b m s =
  [%trace]
    ~call:(fun {pf} -> pf "@ %a = %a" Trm.pp (Trm.concat a0V) Trm.pp b)
    ~retn:(fun {pf} -> pf "%a" pp)
  @@ fun () ->
  let s, n0V =
    Iter.fold (Array.to_iter a0V) (s, Trm.zero) ~f:(fun aJ (s, oI) ->
        let nJ = Trm.seq_size_exn aJ in
        let oJ = Trm.add oI nJ in
        let s = add_pending aJ (Trm.extract ~seq:b ~off:oI ~len:nJ) s in
        (s, oJ) )
  in
  add_pending n0V m s

let solve d e s =
  [%trace]
    ~call:(fun {pf} -> pf "@ %a = %a" Trm.pp d Trm.pp e)
    ~retn:(fun {pf} -> pf "%a" pp)
  @@ fun () ->
  match orient d e with
  (* e' = f' ==> true when e' ≡ f' *)
  | None -> s
  (* i = j ==> false when i ≠ j *)
  | Some (Z _, Z _) | Some (Q _, Q _) -> {s with solved= None}
  (*
   * Concat
   *)
  (* ⟨0,a⟩ = β ==> a = β = ⟨⟩ *)
  | Some (Sized {siz= n; seq= a}, b) when n == Trm.zero ->
      s
      |> add_pending a (Trm.concat [||])
      |> add_pending b (Trm.concat [||])
  | Some (b, Sized {siz= n; seq= a}) when n == Trm.zero ->
      s
      |> add_pending a (Trm.concat [||])
      |> add_pending b (Trm.concat [||])
  (* ⟨n,0⟩ = α₀^…^αᵥ ==> … ∧ αⱼ = ⟨n,0⟩[n₀+…+nᵢ,nⱼ) ∧ … *)
  | Some ((Sized {siz= n; seq} as b), Concat a0V) when seq == Trm.zero ->
      solve_concat a0V b n s
  (* ⟨n,e^⟩ = α₀^…^αᵥ ==> … ∧ αⱼ = ⟨n,e^⟩[n₀+…+nᵢ,nⱼ) ∧ … *)
  | Some ((Sized {siz= n; seq= Splat _} as b), Concat a0V) ->
      solve_concat a0V b n s
  | Some ((Var _ as v), (Concat a0V as c)) ->
      if not (Trm.Set.mem v (Trm.fv c :> Trm.Set.t)) then
        (* v = α₀^…^αᵥ ==> v ↦ α₀^…^αᵥ when v ∉ fv(α₀^…^αᵥ) *)
        add_solved ~var:v ~rep:c s
      else
        (* v = α₀^…^αᵥ ==> ⟨|α₀^…^αᵥ|,v⟩ = α₀^…^αᵥ when v ∈ fv(α₀^…^αᵥ) *)
        let m = Trm.seq_size_exn c in
        solve_concat a0V (Trm.sized ~siz:m ~seq:v) m s
  (* α₀^…^αᵥ = β₀^…^βᵤ ==> … ∧ αⱼ = (β₀^…^βᵤ)[n₀+…+nᵢ,nⱼ) ∧ … *)
  | Some (Concat a0V, (Concat _ as c)) ->
      solve_concat a0V c (Trm.seq_size_exn c) s
  (* α[o,l) = α₀^…^αᵥ ==> … ∧ αⱼ = α[o,l)[n₀+…+nᵢ,nⱼ) ∧ … *)
  | Some ((Extract {len= l} as e), Concat a0V) -> solve_concat a0V e l s
  (*
   * Extract
   *)
  | Some ((Var _ as v), (Extract {len= l} as e)) ->
      if not (Trm.Set.mem v (Trm.fv e :> Trm.Set.t)) then
        (* v = α[o,l) ==> v ↦ α[o,l) when v ∉ fv(α[o,l)) *)
        add_solved ~var:v ~rep:e s
      else
        (* v = α[o,l) ==> α[o,l) ↦ ⟨l,v⟩ when v ∈ fv(α[o,l)) *)
        add_solved ~var:e ~rep:(Trm.sized ~siz:l ~seq:v) s
  (* α[o,l) = β ==> … ∧ α = _^β^_ *)
  | Some (Extract {seq= a; off= o; len= l}, e) ->
      Option.value (solve_extract a o l e s) ~default:s
  (*
   * Sized
   *)
  (* v = ⟨n,a⟩ ==> v = a *)
  | Some ((Var _ as v), Sized {seq= a}) -> s |> add_pending v a
  (* ⟨n,a⟩ = ⟨m,b⟩ ==> n = m ∧ a = β *)
  | Some (Sized {siz= n; seq= a}, Sized {siz= m; seq= b}) ->
      s |> add_pending n m |> add_pending a b
  (* ⟨n,a⟩ = β ==> n = |β| ∧ a = β *)
  | Some (Sized {siz= n; seq= a}, b) ->
      s
      |> Option.fold ~f:(add_pending n) (Trm.seq_size b)
      |> add_pending a b
  (*
   * Splat
   *)
  (* a^ = b^ ==> a = b *)
  | Some (Splat a, Splat b) -> s |> add_pending a b
  (*
   * Arithmetic
   *)
  (* p = q ==> p-q = 0 *)
  | Some (((Arith _ | Z _ | Q _) as p), q | q, ((Arith _ | Z _ | Q _) as p))
    ->
      solve_poly p q s
  (*
   * Uninterpreted
   *)
  (* r = v ==> v ↦ r *)
  | Some (rep, var) ->
      assert (is_noninterpreted var) ;
      assert (is_noninterpreted rep) ;
      add_solved ~var ~rep s