[sledge] Change: Implement Fol using a solver-independent intermediate type

Summary:
In order to allow implementations of the single Fol interface using
multiple backend first-order logic solvers, add explicit definitions
of terms and formulas in the Fol module, and implement Context in
terms of them.

The Fol interface supports freely mixing Terms and Formulas, in
particular there is `Term.ite : cnd:Formula.t -> thn:Term.t ->
els:Term.t -> Term.t` which allows Formulas to appear in Terms. The
Fol implementation performs enough normalization to enable using an
internal representation of terms that is strictly partitioned into
"theory terms" and "formulas", which are stratified below "conditional
terms" and then below "general terms". This partitioning and
stratification enables using backend solvers that do not support
mixing formulas in terms.

Reviewed By: jvillard

Differential Revision: D22170506

fbshipit-source-id: a014ee7d7
master
Josh Berdine 5 years ago committed by Facebook GitHub Bot
parent a6dabc7924
commit 7e77bad4d2

@ -16,39 +16,43 @@ module type S = sig
val true_ : t val true_ : t
module Term : sig module Var : sig
type t type t
val zero : t val of_absval : AbstractValue.t -> t
val le : t -> t -> t val to_absval : t -> AbstractValue.t
(** use with caution: will crash the program if the given variable wasn't generated from an
[AbstractValue.t] using [Var.of_absval] *)
end
val lt : t -> t -> t module Term : sig
type t
val not_ : t -> t val zero : t
val of_intlit : IntLit.t -> t val of_intlit : IntLit.t -> t
val of_absval : AbstractValue.t -> t val of_absval : AbstractValue.t -> t
val of_unop : Unop.t -> t -> t val of_unop : Unop.t -> t -> t option
val of_binop : Binop.t -> t -> t -> t val of_binop : Binop.t -> t -> t -> t option
end end
module Var : sig module Formula : sig
type t type t
val of_absval : AbstractValue.t -> t val eq : Term.t -> Term.t -> t
val to_absval : t -> AbstractValue.t val lt : Term.t -> Term.t -> t
(** use with caution: will crash the program if the given variable wasn't generated from an
[AbstractValue.t] using [Var.of_absval] *)
end
val and_eq : Term.t -> Term.t -> t -> t val not_ : t -> t
val term_binop : Binop.t -> Term.t -> Term.t -> t option
end
val and_term : Term.t -> t -> t val and_formula : Formula.t -> t -> t
val and_ : t -> t -> t val and_ : t -> t -> t

@ -21,19 +21,25 @@ module Term = struct
let zero = () let zero = ()
let le () () = () let of_intlit _ = ()
let lt () () = () let of_absval _ = ()
let not_ () = () let of_unop _ () = None
let of_intlit _ = () let of_binop _ () () = None
end
let of_absval _ = () module Formula = struct
type t = unit
let eq () () = ()
let lt () () = ()
let of_unop _ () = () let not_ () = ()
let of_binop _ () () = () let term_binop _ () () = None
end end
(* same type as {!PulsePathCondition.t} to be nice to summary serialization *) (* same type as {!PulsePathCondition.t} to be nice to summary serialization *)
@ -46,9 +52,7 @@ let pp fmt {eqs= (lazy eqs); non_eqs= (lazy non_eqs)} =
let true_ = {eqs= Lazy.from_val Ses.Equality.true_; non_eqs= Lazy.from_val Ses.Term.true_} let true_ = {eqs= Lazy.from_val Ses.Equality.true_; non_eqs= Lazy.from_val Ses.Term.true_}
let and_eq () () phi = phi let and_formula () phi = phi
let and_term () phi = phi
let and_ phi1 _ = phi1 let and_ phi1 _ = phi1

@ -51,7 +51,7 @@ let and_nonnegative v ({satisfiable; bo_itvs; citvs; pudge} as phi) =
{ satisfiable { satisfiable
; bo_itvs= BoItvs.add v Itv.ItvPure.nat bo_itvs ; bo_itvs= BoItvs.add v Itv.ItvPure.nat bo_itvs
; citvs= CItvs.add v CItv.zero_inf citvs ; citvs= CItvs.add v CItv.zero_inf citvs
; pudge= Pudge.and_term Pudge.Term.(le zero (of_absval v)) pudge } ; pudge= Pudge.(and_formula (Formula.lt Term.zero (Term.of_absval v)) pudge) }
let and_positive v ({satisfiable; bo_itvs; citvs; pudge} as phi) = let and_positive v ({satisfiable; bo_itvs; citvs; pudge} as phi) =
@ -60,7 +60,7 @@ let and_positive v ({satisfiable; bo_itvs; citvs; pudge} as phi) =
{ satisfiable { satisfiable
; bo_itvs= BoItvs.add v Itv.ItvPure.pos bo_itvs ; bo_itvs= BoItvs.add v Itv.ItvPure.pos bo_itvs
; citvs= CItvs.add v (CItv.ge_to IntLit.one) citvs ; citvs= CItvs.add v (CItv.ge_to IntLit.one) citvs
; pudge= Pudge.and_term Pudge.Term.(lt zero (of_absval v)) pudge } ; pudge= Pudge.(and_formula (Formula.lt Term.zero (Term.of_absval v)) pudge) }
let and_eq_int v i ({satisfiable; bo_itvs; citvs; pudge} as phi) = let and_eq_int v i ({satisfiable; bo_itvs; citvs; pudge} as phi) =
@ -69,7 +69,7 @@ let and_eq_int v i ({satisfiable; bo_itvs; citvs; pudge} as phi) =
{ satisfiable { satisfiable
; bo_itvs= BoItvs.add v (Itv.ItvPure.of_int_lit i) bo_itvs ; bo_itvs= BoItvs.add v (Itv.ItvPure.of_int_lit i) bo_itvs
; citvs= CItvs.add v (CItv.equal_to i) citvs ; citvs= CItvs.add v (CItv.equal_to i) citvs
; pudge= Pudge.and_eq (Pudge.Term.of_absval v) (Pudge.Term.of_intlit i) pudge } ; pudge= Pudge.(and_formula (Formula.eq (Term.of_absval v) (Term.of_intlit i)) pudge) }
let simplify ~keep {satisfiable; bo_itvs; citvs; pudge} = let simplify ~keep {satisfiable; bo_itvs; citvs; pudge} =
@ -182,8 +182,9 @@ let and_pudge_callee subst pudge_caller pudge_callee =
let subst', v_caller = subst_find_or_new subst v_callee in let subst', v_caller = subst_find_or_new subst v_callee in
(subst', Pudge.Var.of_absval v_caller) ) (subst', Pudge.Var.of_absval v_caller) )
in in
(* Don't trigger the computation of [path_condition] by asking for satisfiability here. Instead, (* Don't trigger the computation of the underlying Sledge data structure by asking for
pudge (un-)satisfiability is computed lazily when we discover issues. *) satisfiability here. Instead, pudge (un-)satisfiability is computed lazily when we discover
issues. *)
(subst, Pudge.and_ pudge_caller pudge_callee_translated) (subst, Pudge.and_ pudge_caller pudge_callee_translated)
@ -240,16 +241,19 @@ let eval_bo_itv_binop binop_addr bop op_lhs op_rhs bo_itvs =
BoItvs.add binop_addr bo_itv bo_itvs BoItvs.add binop_addr bo_itv bo_itvs
let eval_path_condition_binop binop_addr binop op_lhs op_rhs pudge = let eval_pudge_binop binop_addr binop op_lhs op_rhs pudge =
let open Pudge in
let term_of_op = function let term_of_op = function
| LiteralOperand i -> | LiteralOperand i ->
Pudge.Term.of_intlit i Term.of_intlit i
| AbstractValueOperand v -> | AbstractValueOperand v ->
Pudge.Term.of_absval v Term.of_absval v
in in
Pudge.and_eq (Pudge.Term.of_absval binop_addr) match Term.of_binop binop (term_of_op op_lhs) (term_of_op op_rhs) with
(Pudge.Term.of_binop binop (term_of_op op_lhs) (term_of_op op_rhs)) | None ->
pudge pudge
| Some t_binop ->
and_formula (Formula.eq (Term.of_absval binop_addr) t_binop) pudge
let eval_binop binop_addr binop op_lhs op_rhs ({satisfiable; bo_itvs; citvs; pudge} as phi) = let eval_binop binop_addr binop op_lhs op_rhs ({satisfiable; bo_itvs; citvs; pudge} as phi) =
@ -258,7 +262,7 @@ let eval_binop binop_addr binop op_lhs op_rhs ({satisfiable; bo_itvs; citvs; pud
{ satisfiable { satisfiable
; bo_itvs= eval_bo_itv_binop binop_addr binop op_lhs op_rhs bo_itvs ; bo_itvs= eval_bo_itv_binop binop_addr binop op_lhs op_rhs bo_itvs
; citvs= eval_citv_binop binop_addr binop op_lhs op_rhs citvs ; citvs= eval_citv_binop binop_addr binop op_lhs op_rhs citvs
; pudge= eval_path_condition_binop binop_addr binop op_lhs op_rhs pudge } ; pudge= eval_pudge_binop binop_addr binop op_lhs op_rhs pudge }
let eval_citv_unop unop_addr unop operand_addr citvs = let eval_citv_unop unop_addr unop operand_addr citvs =
@ -278,8 +282,13 @@ let eval_bo_itv_unop unop_addr unop operand_addr bo_itvs =
BoItvs.add unop_addr itv bo_itvs BoItvs.add unop_addr itv bo_itvs
let eval_path_condition_unop unop_addr unop addr pudge = let eval_pudge_unop unop_addr (unop : Unop.t) addr pudge =
Pudge.and_eq (Pudge.Term.of_absval unop_addr) Pudge.Term.(of_unop unop (of_absval addr)) pudge let open Pudge in
match Term.of_unop unop (Term.of_absval addr) with
| None ->
pudge
| Some t_unop ->
and_formula (Formula.eq (Term.of_absval unop_addr) t_unop) pudge
let eval_unop unop_addr unop addr ({satisfiable; bo_itvs; citvs; pudge} as phi) = let eval_unop unop_addr unop addr ({satisfiable; bo_itvs; citvs; pudge} as phi) =
@ -288,7 +297,7 @@ let eval_unop unop_addr unop addr ({satisfiable; bo_itvs; citvs; pudge} as phi)
{ satisfiable { satisfiable
; bo_itvs= eval_bo_itv_unop unop_addr unop addr bo_itvs ; bo_itvs= eval_bo_itv_unop unop_addr unop addr bo_itvs
; citvs= eval_citv_unop unop_addr unop addr citvs ; citvs= eval_citv_unop unop_addr unop addr citvs
; pudge= eval_path_condition_unop unop_addr unop addr pudge } ; pudge= eval_pudge_unop unop_addr unop addr pudge }
let prune_bo_with_bop ~negated v_opt arith bop arith' phi = let prune_bo_with_bop ~negated v_opt arith bop arith' phi =
@ -328,13 +337,16 @@ let bind_satisfiable phi ~f = if phi.satisfiable then f phi else phi
let prune_binop ~negated bop lhs_op rhs_op ({satisfiable; bo_itvs= _; citvs; pudge} as phi) = let prune_binop ~negated bop lhs_op rhs_op ({satisfiable; bo_itvs= _; citvs; pudge} as phi) =
if not satisfiable then phi if not satisfiable then phi
else else
let value_lhs_opt, arith_lhs_opt, bo_itv_lhs, path_cond_lhs = eval_operand phi lhs_op in let value_lhs_opt, arith_lhs_opt, bo_itv_lhs, pudge_lhs = eval_operand phi lhs_op in
let value_rhs_opt, arith_rhs_opt, bo_itv_rhs, path_cond_rhs = eval_operand phi rhs_op in let value_rhs_opt, arith_rhs_opt, bo_itv_rhs, pudge_rhs = eval_operand phi rhs_op in
let phi = let phi =
match Pudge.Formula.term_binop bop pudge_lhs pudge_rhs with
| None ->
phi
| Some f_positive ->
let pudge = let pudge =
let t_positive = Pudge.Term.of_binop bop path_cond_lhs path_cond_rhs in let f = if negated then Pudge.Formula.not_ f_positive else f_positive in
let t = if negated then Pudge.Term.not_ t_positive else t_positive in Pudge.and_formula f pudge
Pudge.and_term t pudge
in in
{phi with pudge} {phi with pudge}
in in

@ -6,14 +6,13 @@
*) *)
open! IStd open! IStd
module F = Format
module L = Logging module L = Logging
module AbstractValue = PulseAbstractValue module AbstractValue = PulseAbstractValue
[@@@warning "+9"] [@@@warning "+9"]
module Var = struct module Var = struct
module Var = Ses.Var module Var = Sledge.Fol.Var
let of_absval (v : AbstractValue.t) = Var.identified ~name:"v" ~id:(v :> int) let of_absval (v : AbstractValue.t) = Var.identified ~name:"v" ~id:(v :> int)
@ -26,153 +25,133 @@ module Var = struct
end end
module Term = struct module Term = struct
module Term = Ses.Term module Term = Sledge.Fol.Term
let of_intlit i = Term.integer (IntLit.to_big_int i) let of_intlit i = Term.integer (IntLit.to_big_int i)
let of_absval v = Term.var (Var.of_absval v) let of_absval v = Term.var (Var.of_absval v)
let of_unop (unop : Unop.t) t = match unop with Neg -> Term.neg t | BNot | LNot -> Term.not_ t let of_unop (unop : Unop.t) t = match unop with Neg -> Some (Term.neg t) | BNot | LNot -> None
let of_binop (binop : Binop.t) t1 t2 = let of_binop (binop : Binop.t) t1 t2 =
let open Term in let open Term in
match binop with match binop with
| PlusA _ | PlusPI -> | PlusA _ | PlusPI ->
add t1 t2 Some (add t1 t2)
| MinusA _ | MinusPI | MinusPP -> | MinusA _ | MinusPI | MinusPP ->
sub t1 t2 Some (sub t1 t2)
| Mult _ -> | Mult _ ->
mul t1 t2 Some (mul t1 t2)
| Div -> | Div | Mod | Shiftlt | Shiftrt | Lt | Gt | Le | Ge | Eq | Ne | BAnd | LAnd | BOr | LOr | BXor
div t1 t2 ->
| Mod -> None
rem t1 t2
| Shiftlt ->
shl t1 t2 include Term
end
module Formula = struct
module Formula = Sledge.Fol.Formula
let term_binop (binop : Binop.t) t1 t2 =
match binop with
| BAnd
| BOr
| BXor
| PlusA _
| PlusPI
| MinusA _
| MinusPI
| MinusPP
| Mult _
| Div
| Mod
| Shiftlt
| Shiftrt -> | Shiftrt ->
lshr t1 t2 Term.of_binop binop t1 t2 |> Option.map ~f:(fun t -> Formula.dq t Term.zero)
| Lt -> | Lt ->
lt t1 t2 Some (Formula.lt t1 t2)
| Gt -> | Gt ->
lt t2 t1 Some (Formula.lt t2 t1)
| Le -> | Le ->
le t1 t2 Some (Formula.le t1 t2)
| Ge -> | Ge ->
le t2 t1 Some (Formula.le t2 t1)
| Eq -> | Eq ->
eq t1 t2 Some (Formula.eq t1 t2)
| Ne -> | Ne ->
dq t1 t2 Some (Formula.dq t1 t2)
| BAnd | LAnd -> | LAnd ->
and_ t1 t2 Option.both (Formula.project t1) (Formula.project t2)
| BOr | LOr -> |> Option.map ~f:(fun (f1, f2) -> Formula.and_ f1 f2)
or_ t1 t2 | LOr ->
| BXor -> Option.both (Formula.project t1) (Formula.project t2)
xor t1 t2 |> Option.map ~f:(fun (f1, f2) -> Formula.or_ f1 f2)
include Term include Formula
end end
module Equality = struct module Context = struct
include Ses.Equality include Sledge.Fol.Context
let assert_no_new_vars api new_vars = let assert_no_new_vars api new_vars =
if not (Var.Set.is_empty new_vars) then if not (Var.Set.is_empty new_vars) then
L.die InternalError "Huho, %s generated fresh new variables %a" api Var.Set.pp new_vars L.die InternalError "Huho, %s generated fresh new variables %a" api Var.Set.pp new_vars
let and_eq t1 t2 r = let and_formula phi r =
let new_vars, r' = Ses.Equality.and_eq Var.Set.empty t1 t2 r in let new_vars, r' = Sledge.Fol.Context.and_formula Var.Set.empty phi r in
assert_no_new_vars "Equality.and_eq" new_vars ; assert_no_new_vars "Context.and_formula" new_vars ;
r'
let and_term t r =
let new_vars, r' = Ses.Equality.and_term Var.Set.empty t r in
assert_no_new_vars "Equality.and_term" new_vars ;
r' r'
let and_ r1 r2 = let and_ r1 r2 =
let new_vars, r' = Ses.Equality.and_ Var.Set.empty r1 r2 in let new_vars, r' = Sledge.Fol.Context.and_ Var.Set.empty r1 r2 in
assert_no_new_vars "Equality.and_" new_vars ; assert_no_new_vars "Context.and_" new_vars ;
r' r'
let apply_subst subst r = let apply_subst subst r =
let new_vars, r' = Ses.Equality.apply_subst Var.Set.empty subst r in let new_vars, r' = Sledge.Fol.Context.apply_subst Var.Set.empty subst r in
assert_no_new_vars "Equality.apply_subst" new_vars ; assert_no_new_vars "Context.apply_subst" new_vars ;
r' r'
end end
(** We distinguish between what the equality relation of sledge can express and the "non-equalities" type t = Context.t lazy_t
terms that this relation ignores. We keep the latter around for completeness: we can still
substitute known equalities into these and sometimes get contradictions back. *)
type t = {eqs: Equality.t lazy_t; non_eqs: Term.t lazy_t}
let pp fmt {eqs= (lazy eqs); non_eqs= (lazy non_eqs)} =
F.fprintf fmt "%a∧%a" Equality.pp eqs Term.pp non_eqs
let true_ = {eqs= Lazy.from_val Equality.true_; non_eqs= Lazy.from_val Term.true_}
let and_eq t1 t2 phi = {phi with eqs= lazy (Equality.and_eq t1 t2 (Lazy.force phi.eqs))} let pp fmt (lazy phi) = Context.pp fmt phi
let and_term (t : Term.t) phi = let true_ = Lazy.from_val Context.true_
(* add the term to the relation *)
let eqs = lazy (Equality.and_term t (Lazy.force phi.eqs)) in
(* [t] normalizes to [true_] so [non_eqs] never changes, do this regardless for now *)
let non_eqs = lazy (Term.and_ (Lazy.force phi.non_eqs) (Equality.normalize (Lazy.force eqs) t)) in
{eqs; non_eqs}
let and_formula f phi = lazy (Context.and_formula f (Lazy.force phi))
let and_ phi1 phi2 = let and_ phi1 phi2 = lazy (Context.and_ (Lazy.force phi1) (Lazy.force phi2))
{ eqs= lazy (Equality.and_ (Lazy.force phi1.eqs) (Lazy.force phi2.eqs))
; non_eqs= lazy (Term.and_ (Lazy.force phi1.non_eqs) (Lazy.force phi2.non_eqs)) }
let is_known_zero t phi = Context.entails_eq (Lazy.force phi) t Term.zero
let is_known_zero t phi = Equality.entails_eq (Lazy.force phi.eqs) t Term.zero let is_unsat phi = Context.is_false (Lazy.force phi)
(* NOTE: not normalizing non_eqs here gives imprecise results but is cheaper *)
let is_unsat {eqs; non_eqs} =
(* [Term.is_false] is cheap, forcing [eqs] is expensive, then calling [Equality.normalize] is
expensive on top of that *)
Term.is_false (Lazy.force non_eqs)
|| Equality.is_false (Lazy.force eqs)
|| Term.is_false (Equality.normalize (Lazy.force eqs) (Lazy.force non_eqs))
let fv {eqs= (lazy eqs); non_eqs= (lazy non_eqs)} =
Term.Var.Set.union (Equality.fv eqs) (Term.fv non_eqs)
let fv (lazy phi) = Context.fv phi
let fold_map_variables phi ~init ~f = let fold_map_variables phi ~init ~f =
let term_fold_map t ~init ~f = let acc, phi' =
Term.fold_map_rec_pre t ~init ~f:(fun acc t -> Context.classes (Lazy.force phi)
Var.of_term t |> Term.Map.fold ~init:(init, Context.true_) ~f:(fun ~key:t ~data:equal_ts (acc, phi') ->
|> Option.map ~f:(fun v -> let acc, t' = Term.fold_map_vars ~init:acc ~f t in
let acc', v' = f acc v in List.fold equal_ts ~init:(acc, phi') ~f:(fun (acc, phi') equal_t ->
(acc', Term.var v') ) ) let acc, t_mapped = Term.fold_map_vars ~init:acc ~f equal_t in
in (acc, Context.and_formula (Formula.eq t' t_mapped) phi') ) )
let acc, eqs' =
Equality.classes (Lazy.force phi.eqs)
|> Term.Map.fold ~init:(init, Equality.true_) ~f:(fun ~key:t ~data:equal_ts (acc, eqs') ->
let acc, t' = term_fold_map ~init:acc ~f t in
List.fold equal_ts ~init:(acc, eqs') ~f:(fun (acc, eqs') equal_t ->
let acc, t_mapped = term_fold_map ~init:acc ~f equal_t in
(acc, Equality.and_eq t' t_mapped eqs') ) )
in in
let acc, non_eqs' = term_fold_map ~init:acc ~f (Lazy.force phi.non_eqs) in (acc, Lazy.from_val phi')
(acc, {eqs= Lazy.from_val eqs'; non_eqs= Lazy.from_val non_eqs'})
let simplify ~keep phi = let simplify ~keep phi =
let all_vs = fv phi in let all_vs = fv phi in
let keep_vs = let keep_vs =
AbstractValue.Set.fold AbstractValue.Set.fold
(fun v keep_vs -> Term.Var.Set.add keep_vs (Var.of_absval v)) (fun v keep_vs -> Var.Set.add keep_vs (Var.of_absval v))
keep Term.Var.Set.empty keep Var.Set.empty
in in
let simpl_subst = Equality.solve_for_vars [keep_vs; all_vs] (Lazy.force phi.eqs) in let simpl_subst = Context.solve_for_vars [keep_vs; all_vs] (Lazy.force phi) in
{phi with eqs= Lazy.from_val (Equality.apply_subst simpl_subst (Lazy.force phi.eqs))} Lazy.from_val (Context.apply_subst simpl_subst (Lazy.force phi))

File diff suppressed because it is too large Load Diff

@ -10,6 +10,7 @@ module Var : sig
type t [@@deriving compare, equal, sexp] type t [@@deriving compare, equal, sexp]
type strength = t -> [`Universal | `Existential | `Anonymous] option type strength = t -> [`Universal | `Existential | `Anonymous] option
val ppx : strength -> t pp
val pp : t pp val pp : t pp
module Map : Map.S with type key := t module Map : Map.S with type key := t
@ -98,17 +99,22 @@ module rec Term : sig
val const_of : t -> Q.t option val const_of : t -> Q.t option
(** Transform *) (** Query *)
val rename : Var.Subst.t -> t -> t val fv : t -> Var.Set.t
(** Traverse *) (** Traverse *)
val fold_vars : t -> init:'a -> f:('a -> Var.t -> 'a) -> 'a val fold_vars : init:'a -> t -> f:('a -> Var.t -> 'a) -> 'a
(** Query *) (** Transform *)
val fv : t -> Var.Set.t val map_vars : f:(Var.t -> Var.t) -> t -> t
val fold_map_vars :
t -> init:'a -> f:('a -> Var.t -> 'a * Var.t) -> 'a * t
val rename : Var.Subst.t -> t -> t
end end
(** Formulas *) (** Formulas *)
@ -140,16 +146,25 @@ and Formula : sig
val or_ : t -> t -> t val or_ : t -> t -> t
val cond : cnd:t -> pos:t -> neg:t -> t val cond : cnd:t -> pos:t -> neg:t -> t
(** Transform *)
val rename : Var.Subst.t -> t -> t
val disjuncts : t -> t list
(** Query *) (** Query *)
val fv : t -> Var.Set.t
val is_true : t -> bool val is_true : t -> bool
val is_false : t -> bool val is_false : t -> bool
val fv : t -> Var.Set.t
(** Traverse *)
val fold_vars : init:'a -> t -> f:('a -> Var.t -> 'a) -> 'a
(** Transform *)
val map_vars : f:(Var.t -> Var.t) -> t -> t
val fold_map_vars :
init:'a -> t -> f:('a -> Var.t -> 'a * Var.t) -> 'a * t
val rename : Var.Subst.t -> t -> t
val disjuncts : t -> t list
end end
(** Inference System *) (** Inference System *)
@ -214,7 +229,7 @@ module Context : sig
implies [a = b+k], or [None] if [a] and [b] are not equal up to an implies [a = b+k], or [None] if [a] and [b] are not equal up to an
integer offset. *) integer offset. *)
val fold_terms : t -> init:'a -> f:('a -> Term.t -> 'a) -> 'a val fold_terms : init:'a -> t -> f:('a -> Term.t -> 'a) -> 'a
(** Solution Substitutions *) (** Solution Substitutions *)
module Subst : sig module Subst : sig

@ -1040,6 +1040,8 @@ module Var = struct
| Some v -> v | Some v -> v
| _ -> violates Llair.Reg.invariant r | _ -> violates Llair.Reg.invariant r
let program ~name ~global = Var {name; id= (if global then -1 else 0)}
let fresh name ~wrt = let fresh name ~wrt =
let max = match Set.max_elt wrt with None -> 0 | Some max -> id max in let max = match Set.max_elt wrt with None -> 0 | Some max -> id max in
let x' = Var {name; id= max + 1} in let x' = Var {name; id= max + 1} in

@ -128,6 +128,7 @@ module Var : sig
val of_ : term -> t val of_ : term -> t
val of_term : term -> t option val of_term : term -> t option
val of_reg : Llair.Reg.t -> t val of_reg : Llair.Reg.t -> t
val program : name:string -> global:bool -> t
val fresh : string -> wrt:Set.t -> t * Set.t val fresh : string -> wrt:Set.t -> t * Set.t
val identified : name:string -> id:int -> t val identified : name:string -> id:int -> t

@ -85,7 +85,7 @@ let%test_module _ =
) )
( ( %x_6, %x_7 . 2 = %x_7 (%x_7 = 2) emp) ( ( %x_6, %x_7 . 2 = %x_7 (%x_7 = 2) emp)
( %x_6 . 1 = %x_6 = %y_7 ((%x_6 = 1) && (%y_7 = 1)) emp) ( %x_6 . 1 = %x_6 = %y_7 ((%x_6 = 1) (%y_7 = 1)) emp)
( 0 = %x_6 (%x_6 = 0) emp) ( 0 = %x_6 (%x_6 = 0) emp)
) |}] ) |}]
@ -112,7 +112,7 @@ let%test_module _ =
( ( %x_6, %x_8, %x_9 . 2 = %x_9 (%x_9 = 2) emp) ( ( %x_6, %x_8, %x_9 . 2 = %x_9 (%x_9 = 2) emp)
( %x_6, %x_8 . ( %x_6, %x_8 .
1 = %y_7 = %x_8 1 = %y_7 = %x_8
((%y_7 = 1) && (%x_8 = 1)) ((%x_8 = 1) (%y_7 = 1))
emp) emp)
( %x_6 . 0 = %x_6 (%x_6 = 0) emp) ( %x_6 . 0 = %x_6 (%x_6 = 0) emp)
) |}] ) |}]
@ -149,7 +149,7 @@ let%test_module _ =
{| {|
%x_6 . %x_6 = %x_6^ (%y_7 + -1) = %y_7^ emp %x_6 . %x_6 = %x_6^ (%y_7 + -1) = %y_7^ emp
(%y_7 + -1) = %y_7^ (%y_7^ = (%y_7 + -1)) emp (%y_7 + -1) = %y_7^ (%y_7^ = ((-1 × 1) + (1 × %y_7))) emp
(%y_7 + -1) = %y_7^ emp |}] (%y_7 + -1) = %y_7^ emp |}]
@ -173,7 +173,7 @@ let%test_module _ =
{| {|
%a_1, %c_3, %d_4, %e_5 . %a_1, %c_3, %d_4, %e_5 .
(8,%a_1^8,%d_4) = %e_5 (8,%a_1^8,%d_4) = %e_5
(16,%e_5 = (8,%a_1^8,%d_4)) ((16,%e_5 = (8,%a_1^8,%d_4)) tt)
emp emp
* ( ( (%x_6 0) emp) * ( ( (%x_6 0) emp)
( %b_2 . ( %b_2 .
@ -182,7 +182,7 @@ let%test_module _ =
emp) emp)
) )
-1 emp * ( ( -1 emp) ( (%x_6 0) emp) ) tt emp * ( ( tt emp) ( (%x_6 0) emp) )
( ( emp) ( (%x_6 0) emp) ) |}] ( ( emp) ( (%x_6 0) emp) ) |}]
end ) end )

@ -196,7 +196,7 @@ let%test_module _ =
%a_2 = %a0_10 %a_2 = %a0_10
(16,%a_2^16,%a1_11) = %a_1 (16,%a_2^16,%a1_11) = %a_1
16 = %m_8 = %n_9 16 = %m_8 = %n_9
(%k_5 + 16) -[ %k_5, 16 )-> 16,%a1_11 |}] ((16 × 1) + (1 × %k_5)) -[ %k_5, 16 )-> 16,%a1_11 |}]
let%expect_test _ = let%expect_test _ =
infer_frame infer_frame
@ -218,7 +218,7 @@ let%test_module _ =
%a_2 = %a0_10 %a_2 = %a0_10
(16,%a_2^16,%a1_11) = %a_1 (16,%a_2^16,%a1_11) = %a_1
16 = %m_8 = %n_9 16 = %m_8 = %n_9
(%k_5 + 16) -[ %k_5, 16 )-> 16,%a1_11 |}] ((16 × 1) + (1 × %k_5)) -[ %k_5, 16 )-> 16,%a1_11 |}]
let seg_split_symbolically = let seg_split_symbolically =
Sh.star Sh.star
@ -236,7 +236,7 @@ let%test_module _ =
[%expect [%expect
{| {|
( infer_frame: ( infer_frame:
%l_6 -[ %l_6, 16 )-> (8 × %n_9),%a_2^(-8 × %n_9 + 16),%a_3 %l_6 -[ %l_6, 16 )-> (8 × %n_9),%a_2^(16 - (8 × %n_9)),%a_3
* ( ( 2 = %n_9 emp) * ( ( 2 = %n_9 emp)
( 0 = %n_9 emp) ( 0 = %n_9 emp)
( 1 = %n_9 emp) ( 1 = %n_9 emp)
@ -247,7 +247,7 @@ let%test_module _ =
( ( %a_1 = %a_2 ( ( %a_1 = %a_2
2 = %n_9 2 = %n_9
16 = %m_8 16 = %m_8
(%l_6 + 16) -[ %l_6, 16 )-> 0,%a_3) ((16 × 1) + (1 × %l_6)) -[ %l_6, 16 )-> 0,%a_3)
( %a_3 = _ ( %a_3 = _
(8,%a_2^8,%a_3) = %a_1 (8,%a_2^8,%a_3) = %a_1
1 = %n_9 1 = %n_9
@ -269,8 +269,8 @@ let%test_module _ =
[%expect [%expect
{| {|
( infer_frame: ( infer_frame:
(%n_9 2) ((%n_9 2) (tt tt))
%l_6 -[ %l_6, 16 )-> (8 × %n_9),%a_2^(-8 × %n_9 + 16),%a_3 %l_6 -[ %l_6, 16 )-> (8 × %n_9),%a_2^(16 - (8 × %n_9)),%a_3
\- %a_1, %m_8 . \- %a_1, %m_8 .
%l_6 -[ %l_6, %m_8 )-> %m_8,%a_1 %l_6 -[ %l_6, %m_8 )-> %m_8,%a_1
) infer_frame: |}] ) infer_frame: |}]

Loading…
Cancel
Save