From 163e9f3fc5fadb0bb028a8ce1d39ef72e0a076f0 Mon Sep 17 00:00:00 2001 From: N1ark Date: Sun, 15 Sep 2024 15:15:15 +0100 Subject: [PATCH 01/54] Add `Asrt.t = Asrt.simple list` --- GillianCore/GIL_Syntax/Asrt.ml | 202 ++++++++++---------------- GillianCore/GIL_Syntax/Gil_syntax.mli | 93 +++++++----- GillianCore/GIL_Syntax/Lemma.ml | 15 +- GillianCore/GIL_Syntax/Pred.ml | 12 +- GillianCore/GIL_Syntax/Spec.ml | 8 +- GillianCore/GIL_Syntax/TypeDef__.ml | 6 +- GillianCore/gil_parser/GIL_Parser.mly | 26 ++-- 7 files changed, 162 insertions(+), 200 deletions(-) diff --git a/GillianCore/GIL_Syntax/Asrt.ml b/GillianCore/GIL_Syntax/Asrt.ml index e47e70a1..03c15815 100644 --- a/GillianCore/GIL_Syntax/Asrt.ml +++ b/GillianCore/GIL_Syntax/Asrt.ml @@ -1,15 +1,19 @@ (** {b GIL logic assertions}. *) -type t = TypeDef__.assertion = +type simple = TypeDef__.assertion_simple = | Emp (** Empty heap *) - | Star of t * t (** Separating conjunction *) | Pred of string * Expr.t list (** Predicates *) | Pure of Formula.t (** Pure formula *) | Types of (Expr.t * Type.t) list (** Typing assertion *) - | GA of string * Expr.t list * Expr.t list (** Core assertion *) + | CorePred of string * Expr.t list * Expr.t list + (** Core assertion *) | Wand of { lhs : string * Expr.t list; rhs : string * Expr.t list } (** Magic wand of the form [P(...) -* Q(...)] *) [@@deriving eq] +type t = TypeDef__.assertion [@@deriving eq] + +let simple_to_yojson = TypeDef__.assertion_simple_to_yojson +let simple_of_yojson = TypeDef__.assertion_simple_of_yojson let to_yojson = TypeDef__.assertion_to_yojson let of_yojson = TypeDef__.assertion_of_yojson @@ -27,7 +31,7 @@ let compare x y = | _, Types _ -> 1 | _, _ -> cmp x y -let prioritise (a1 : t) (a2 : t) = +let prioritise (a1 : simple) (a2 : simple) = let lloc_aloc_pvar_lvar e1 e2 = match ((e1 : Expr.t), (e2 : Expr.t)) with | Lit (Loc _), Lit (Loc _) -> 0 @@ -65,65 +69,58 @@ end module Set = Set.Make (MyAssertion) (** Deprecated, use {!Visitors.endo} instead. *) -let rec map - (f_a_before : (t -> t * bool) option) - (f_a_after : (t -> t) option) +let map + (f_a_before : (simple -> t) option) + (f_a_after : (simple -> t) option) (f_e : (Expr.t -> Expr.t) option) (f_p : (Formula.t -> Formula.t) option) (a : t) : t = (* Map recursively to assertions and expressions *) - let map_a = map f_a_before f_a_after f_e f_p in let map_e = Option.value ~default:(fun x -> x) f_e in let map_p = Option.value ~default:(Formula.map None None (Some map_e)) f_p in - let f_a_before = Option.value ~default:(fun x -> (x, true)) f_a_before in - let f_a_after = Option.value ~default:(fun x -> x) f_a_after in - let a', recurse = f_a_before a in - - if not recurse then a' - else - let a'' = - match a' with - | Star (a1, a2) -> Star (map_a a1, map_a a2) - | Emp -> Emp - | Pred (s, le) -> Pred (s, List.map map_e le) - | Pure form -> Pure (map_p form) - | Types lt -> Types (List.map (fun (exp, typ) -> (map_e exp, typ)) lt) - | GA (x, es1, es2) -> GA (x, List.map map_e es1, List.map map_e es2) - | Wand { lhs = lhs_pred, lhs_args; rhs = rhs_pred, rhs_args } -> - Wand - { - lhs = (lhs_pred, List.map map_e lhs_args); - rhs = (rhs_pred, List.map map_e rhs_args); - } - in - f_a_after a'' + let f_a_before = Option.value ~default:(fun x -> [ x ]) f_a_before in + let f_a_after = Option.value ~default:(fun x -> [ x ]) f_a_after in + let a' = List.concat_map f_a_before a in + + a' + |> List.map (function + | Emp -> Emp + | Pred (s, le) -> Pred (s, List.map map_e le) + | Pure form -> Pure (map_p form) + | Types lt -> Types (List.map (fun (exp, typ) -> (map_e exp, typ)) lt) + | CorePred (x, es1, es2) -> + CorePred (x, List.map map_e es1, List.map map_e es2) + | Wand { lhs = lhs_pred, lhs_args; rhs = rhs_pred, rhs_args } -> + Wand + { + lhs = (lhs_pred, List.map map_e lhs_args); + rhs = (rhs_pred, List.map map_e rhs_args); + }) + |> List.concat_map f_a_after (* Get all the logical expressions of --a-- that denote a list and are not logical variables *) -let list_lexprs (a : t) : Expr.Set.t = - Formula.list_lexprs_collector#visit_assertion () a +let list_lexprs : t -> Expr.Set.t = + Formula.list_lexprs_collector#visit_assertion () (* Get all the logical variables in --a-- *) -let lvars (a : t) : SS.t = - Visitors.Collectors.lvar_collector#visit_assertion SS.empty a +let lvars : t -> SS.t = + Visitors.Collectors.lvar_collector#visit_assertion SS.empty (* Get all the program variables in --a-- *) -let pvars (a : t) : SS.t = - Visitors.Collectors.pvar_collector#visit_assertion () a +let pvars : t -> SS.t = Visitors.Collectors.pvar_collector#visit_assertion () (* Get all the abstract locations in --a-- *) -let alocs (a : t) : SS.t = - Visitors.Collectors.aloc_collector#visit_assertion () a +let alocs : t -> SS.t = Visitors.Collectors.aloc_collector#visit_assertion () (* Get all the concrete locations in [a] *) -let clocs (a : t) : SS.t = - Visitors.Collectors.cloc_collector#visit_assertion () a +let clocs : t -> SS.t = Visitors.Collectors.cloc_collector#visit_assertion () (* Get all the concrete locations in [a] *) -let locs (a : t) : SS.t = Visitors.Collectors.loc_collector#visit_assertion () a +let locs : t -> SS.t = Visitors.Collectors.loc_collector#visit_assertion () (* Returns a list with the names of the predicates that occur in --a-- *) -let pred_names (a : t) : string list = +let pred_names : t -> string list = let collector = object inherit [_] Visitors.reduce @@ -131,10 +128,10 @@ let pred_names (a : t) : string list = method! visit_Pred () name _ = [ name ] end in - collector#visit_assertion () a + collector#visit_assertion () (* Returns a list with the pure assertions that occur in --a-- *) -let pure_asrts (a : t) : Formula.t list = +let pure_asrts : t -> Formula.t list = let collector = object inherit [_] Visitors.reduce @@ -142,122 +139,77 @@ let pure_asrts (a : t) : Formula.t list = method! visit_Pure () f = [ f ] end in - collector#visit_assertion () a + collector#visit_assertion () (* Returns a list with the simple assertions that occur in --a-- *) -let rec simple_asrts (a : t) : t list = - match a with - | Emp -> [] - | Star (a1, a2) -> simple_asrts a1 @ simple_asrts a2 - | _ -> [ a ] +(* TODO: remove *) +let simple_asrts : t -> t = List.filter (fun x -> x <> Emp) (* Check if --a-- is a pure assertion *) -let rec is_pure_asrt (a : t) : bool = - match a with - | Pred _ | GA _ -> false - | Star (a1, a2) -> is_pure_asrt a1 && is_pure_asrt a2 +let is_pure_asrt : simple -> bool = function + | Pred _ | CorePred _ | Wand _ -> false | _ -> true (* Check if --a-- is a pure assertion & non-recursive assertion. It assumes that only pure assertions are universally quantified *) -let is_pure_non_rec_asrt (a : t) : bool = - match a with - | Pure _ | Types _ | Emp -> true - | _ -> false +(* TODO: remove *) +let is_pure_non_rec_asrt : simple -> bool = is_pure_asrt (* Eliminate LStar and LTypes assertions. LTypes disappears. LStar is replaced by LAnd. This function expects its argument to be a PURE assertion. *) let make_pure (a : t) : Formula.t = - let s_asrts = simple_asrts a in - let all_pure = List.for_all is_pure_non_rec_asrt s_asrts in - if all_pure then - let fs = - List.map - (fun a -> - match a with - | Pure f -> f - | _ -> raise (Failure "DEATH. make_pure")) - s_asrts - in - Formula.conjunct fs - else raise (Failure "DEATH. make_pure") - -let rec full_pp fmt a = - match a with - | Star (a1, a2) -> Fmt.pf fmt "%a *@ %a" full_pp a1 full_pp a2 - | Emp -> Fmt.string fmt "emp" - | Pred (name, params) -> - let name = Pp_utils.maybe_quote_ident name in - Fmt.pf fmt "@[%s(%a)@]" name - (Fmt.list ~sep:Fmt.comma Expr.full_pp) - params - | Types tls -> - let pp_tl f (e, t) = Fmt.pf f "%a : %s" Expr.full_pp e (Type.str t) in - Fmt.pf fmt "types(@[%a@])" (Fmt.list ~sep:Fmt.comma pp_tl) tls - | Pure f -> Formula.full_pp fmt f - | GA (a, ins, outs) -> - let pp_e_l = Fmt.list ~sep:Fmt.comma Expr.full_pp in - Fmt.pf fmt "@[<%s>(%a; %a)@]" a pp_e_l ins pp_e_l outs - | Wand { lhs = lname, largs; rhs = rname, rargs } -> - let lname = Pp_utils.maybe_quote_ident lname in - let rname = Pp_utils.maybe_quote_ident rname in - Fmt.pf fmt "(%s(%a) -* %s(%a))" lname - (Fmt.list ~sep:Fmt.comma Expr.full_pp) - largs rname - (Fmt.list ~sep:Fmt.comma Expr.full_pp) - rargs + a + |> List.filter_map (function + | Pure f -> Some f + | Emp -> None + | _ -> raise (Failure "DEATH. make_pure received unpure assertion")) + |> Formula.conjunct (** GIL logic assertions *) -let rec pp fmt a = - match a with - | Star (a1, a2) -> Fmt.pf fmt "%a *@ %a" pp a1 pp a2 +let _simple_pp ?(e_pp : Format.formatter -> Expr.t -> unit = Expr.pp) fmt = + function | Emp -> Fmt.string fmt "emp" | Pred (name, params) -> let name = Pp_utils.maybe_quote_ident name in - Fmt.pf fmt "@[%s(%a)@]" name (Fmt.list ~sep:Fmt.comma Expr.pp) params + Fmt.pf fmt "@[%s(%a)@]" name (Fmt.list ~sep:Fmt.comma e_pp) params | Types tls -> - let pp_tl f (e, t) = Fmt.pf f "%a : %s" Expr.pp e (Type.str t) in + let pp_tl f (e, t) = Fmt.pf f "%a : %s" e_pp e (Type.str t) in Fmt.pf fmt "types(@[%a@])" (Fmt.list ~sep:Fmt.comma pp_tl) tls | Pure f -> Formula.pp fmt f - | GA (a, ins, outs) -> - let pp_e_l = Fmt.list ~sep:Fmt.comma Expr.pp in + | CorePred (a, ins, outs) -> + let pp_e_l = Fmt.list ~sep:Fmt.comma e_pp in Fmt.pf fmt "@[<%s>(%a; %a)@]" a pp_e_l ins pp_e_l outs | Wand { lhs = lname, largs; rhs = rname, rargs } -> let lname = Pp_utils.maybe_quote_ident lname in let rname = Pp_utils.maybe_quote_ident rname in Fmt.pf fmt "(%s(%a) -* %s(%a))" lname - (Fmt.list ~sep:Fmt.comma Expr.pp) + (Fmt.list ~sep:Fmt.comma e_pp) largs rname - (Fmt.list ~sep:Fmt.comma Expr.pp) + (Fmt.list ~sep:Fmt.comma e_pp) rargs -let subst_clocs (subst : string -> Expr.t) (a : t) : t = +let _pp ~(e_pp : Format.formatter -> Expr.t -> unit) (fmt : Format.formatter) : + t -> unit = + Fmt.list ~sep:(Fmt.any " *@ ") (_simple_pp ~e_pp) fmt + +let simple_pp = _simple_pp ~e_pp:Expr.pp +let simple_full_pp = _simple_pp ~e_pp:Expr.full_pp +let pp = _pp ~e_pp:Expr.pp +let full_pp = _pp ~e_pp:Expr.full_pp + +let subst_clocs (subst : string -> Expr.t) : t -> t = map None None (Some (Expr.subst_clocs subst)) (Some (Formula.subst_clocs subst)) - a -let subst_expr_for_expr ~(to_subst : Expr.t) ~(subst_with : Expr.t) (a : t) : t - = +let subst_expr_for_expr ~(to_subst : Expr.t) ~(subst_with : Expr.t) : t -> t = map None None (Some (Expr.subst_expr_for_expr ~to_subst ~subst_with)) (Some (Formula.subst_expr_for_expr ~to_subst ~subst_with)) - a - -module Infix = struct - let ( ** ) a b = - match (a, b) with - | Pure True, x | x, Pure True | Emp, x | x, Emp -> x - | (Pure False as fl), _ | _, (Pure False as fl) -> fl - | _ -> Star (a, b) - - let ( --* ) lhs rhs = Wand { lhs; rhs } -end -let star (asrts : t list) : t = List.fold_left Infix.( ** ) Emp asrts +let pvars_to_lvars : t -> t = + map None None (Some Expr.pvars_to_lvars) (Some Formula.pvars_to_lvars) -let pvars_to_lvars (a : t) : t = - let ff = Formula.pvars_to_lvars in - let fe = Expr.pvars_to_lvars in - map None None (Some fe) (Some ff) a +(* TODO: remove *) +let star : t list -> t = List.concat diff --git a/GillianCore/GIL_Syntax/Gil_syntax.mli b/GillianCore/GIL_Syntax/Gil_syntax.mli index 9bdd4d22..26299c32 100644 --- a/GillianCore/GIL_Syntax/Gil_syntax.mli +++ b/GillianCore/GIL_Syntax/Gil_syntax.mli @@ -563,30 +563,31 @@ end module Asrt : sig (** GIL Assertions *) - type t = + type simple = | Emp (** Empty heap *) - | Star of t * t (** Separating conjunction *) | Pred of string * Expr.t list (** Predicates *) | Pure of Formula.t (** Pure formula *) | Types of (Expr.t * Type.t) list (** Typing assertion *) - | GA of string * Expr.t list * Expr.t list (** Core assertion *) + | CorePred of string * Expr.t list * Expr.t list (** Core assertion *) | Wand of { lhs : string * Expr.t list; rhs : string * Expr.t list } (** Magic wand of the form [P(...) -* Q(...)] *) [@@deriving yojson, eq] + type t = simple list [@@deriving yojson, eq] + (** Comparison of assertions *) - val compare : t -> t -> int + val compare : simple -> simple -> int (** Sorting of assertions *) - val prioritise : t -> t -> int + val prioritise : simple -> simple -> int (** Sets of assertions *) module Set : Set.S with type elt := t (** @deprecated Use {!Visitors.endo} instead *) val map : - (t -> t * bool) option -> - (t -> t) option -> + (simple -> t) option -> + (simple -> t) option -> (Expr.t -> Expr.t) option -> (Formula.t -> Formula.t) option -> t -> @@ -618,14 +619,14 @@ module Asrt : sig val pure_asrts : t -> Formula.t list (** Returns a list with the pure assertions that occur in [a] *) - val simple_asrts : t -> t list + val simple_asrts : t -> t (** Check if [a] is a pure assertion *) - val is_pure_asrt : t -> bool + val is_pure_asrt : simple -> bool (** Check if [a] is a pure assertion & non-recursive assertion. It assumes that only pure assertions are universally quantified *) - val is_pure_non_rec_asrt : t -> bool + val is_pure_non_rec_asrt : simple -> bool (** Eliminate LStar and LTypes assertions. LTypes disappears. LStar is replaced by LAnd. @@ -649,11 +650,6 @@ module Asrt : sig (** Move pvars to lvars *) val pvars_to_lvars : t -> t - - module Infix : sig - (** Star constructor *) - val ( ** ) : t -> t -> t - end end (** @canonical Gillian.Gil_syntax.SLCmd *) @@ -1322,7 +1318,7 @@ module Visitors : sig 'c -> Expr.t -> (string * Type.t option) list -> Expr.t -> Expr.t ; visit_EForall : 'c -> Expr.t -> (string * Type.t option) list -> Expr.t -> Expr.t - ; visit_Emp : 'c -> Asrt.t -> Asrt.t + ; visit_Emp : 'c -> Asrt.simple -> Asrt.simple ; visit_Empty : 'c -> Literal.t -> Literal.t ; visit_EmptyType : 'c -> Type.t -> Type.t ; visit_Epsilon : 'c -> Constant.t -> Constant.t @@ -1352,14 +1348,19 @@ module Visitors : sig (string * Type.t option) list -> Formula.t -> Formula.t - ; visit_GA : - 'c -> Asrt.t -> string -> Expr.t list -> Expr.t list -> Asrt.t + ; visit_CorePred : + 'c -> + Asrt.simple -> + string -> + Expr.t list -> + Expr.t list -> + Asrt.simple ; visit_Wand : 'c -> - Asrt.t -> + Asrt.simple -> string * Expr.t list -> string * Expr.t list -> - Asrt.t + Asrt.simple ; visit_GUnfold : 'c -> SLCmd.t -> string -> SLCmd.t ; visit_Goto : 'c -> 'f Cmd.t -> 'f -> 'f Cmd.t ; visit_GuardedGoto : 'c -> 'f Cmd.t -> Expr.t -> 'f -> 'f -> 'f Cmd.t @@ -1437,8 +1438,9 @@ module Visitors : sig ; visit_PhiAssignment : 'c -> 'f Cmd.t -> (string * Expr.t list) list -> 'f Cmd.t ; visit_Pi : 'c -> Constant.t -> Constant.t - ; visit_Pred : 'c -> Asrt.t -> string -> Expr.t list -> Asrt.t - ; visit_Pure : 'c -> Asrt.t -> Formula.t -> Asrt.t + ; visit_Pred : + 'c -> Asrt.simple -> string -> Expr.t list -> Asrt.simple + ; visit_Pure : 'c -> Asrt.simple -> Formula.t -> Asrt.simple ; visit_Random : 'c -> Constant.t -> Constant.t ; visit_ReturnError : 'c -> 'f Cmd.t -> 'f Cmd.t ; visit_ReturnNormal : 'c -> 'f Cmd.t -> 'f Cmd.t @@ -1457,7 +1459,6 @@ module Visitors : sig ; visit_SignedRightShiftF : 'c -> BinOp.t -> BinOp.t ; visit_Skip : 'c -> 'f Cmd.t -> 'f Cmd.t ; visit_FreshSVar : 'c -> LCmd.t -> string -> LCmd.t - ; visit_Star : 'c -> Asrt.t -> Asrt.t -> Asrt.t -> Asrt.t ; visit_StrCat : 'c -> BinOp.t -> BinOp.t ; visit_StrLen : 'c -> UnOp.t -> UnOp.t ; visit_NumToInt : 'c -> UnOp.t -> UnOp.t @@ -1477,7 +1478,8 @@ module Visitors : sig ; visit_Type : 'c -> Literal.t -> Type.t -> Literal.t ; visit_TypeOf : 'c -> UnOp.t -> UnOp.t ; visit_TypeType : 'c -> Type.t -> Type.t - ; visit_Types : 'c -> Asrt.t -> (Expr.t * Type.t) list -> Asrt.t + ; visit_Types : + 'c -> Asrt.simple -> (Expr.t * Type.t) list -> Asrt.simple ; visit_UNot : 'c -> UnOp.t -> UnOp.t ; visit_UTCTime : 'c -> Constant.t -> Constant.t ; visit_UnOp : 'c -> Expr.t -> UnOp.t -> Expr.t -> Expr.t @@ -1500,6 +1502,7 @@ module Visitors : sig ; visit_UnsignedRightShift : 'c -> BinOp.t -> BinOp.t ; visit_UnsignedRightShiftL : 'c -> BinOp.t -> BinOp.t ; visit_UnsignedRightShiftF : 'c -> BinOp.t -> BinOp.t + ; visit_assertion_simple : 'c -> Asrt.simple -> Asrt.simple ; visit_assertion : 'c -> Asrt.t -> Asrt.t ; visit_bindings : 'c -> @@ -1591,7 +1594,7 @@ module Visitors : sig method visit_EForall : 'c -> Expr.t -> (string * Type.t option) list -> Expr.t -> Expr.t - method visit_Emp : 'c -> Asrt.t -> Asrt.t + method visit_Emp : 'c -> Asrt.simple -> Asrt.simple method visit_Empty : 'c -> Literal.t -> Literal.t method visit_EmptyType : 'c -> Type.t -> Type.t method visit_Epsilon : 'c -> Constant.t -> Constant.t @@ -1620,11 +1623,15 @@ module Visitors : sig method visit_ForAll : 'c -> Formula.t -> (string * Type.t option) list -> Formula.t -> Formula.t - method visit_GA : - 'c -> Asrt.t -> string -> Expr.t list -> Expr.t list -> Asrt.t + method visit_CorePred : + 'c -> Asrt.simple -> string -> Expr.t list -> Expr.t list -> Asrt.simple method visit_Wand : - 'c -> Asrt.t -> string * Expr.t list -> string * Expr.t list -> Asrt.t + 'c -> + Asrt.simple -> + string * Expr.t list -> + string * Expr.t list -> + Asrt.simple method visit_GUnfold : 'c -> SLCmd.t -> string -> SLCmd.t method visit_Goto : 'c -> 'f Cmd.t -> 'f -> 'f Cmd.t @@ -1709,8 +1716,11 @@ module Visitors : sig 'c -> 'f Cmd.t -> (string * Expr.t list) list -> 'f Cmd.t method visit_Pi : 'c -> Constant.t -> Constant.t - method visit_Pred : 'c -> Asrt.t -> string -> Expr.t list -> Asrt.t - method visit_Pure : 'c -> Asrt.t -> Formula.t -> Asrt.t + + method visit_Pred : + 'c -> Asrt.simple -> string -> Expr.t list -> Asrt.simple + + method visit_Pure : 'c -> Asrt.simple -> Formula.t -> Asrt.simple method visit_Random : 'c -> Constant.t -> Constant.t method visit_ReturnError : 'c -> 'f Cmd.t -> 'f Cmd.t method visit_ReturnNormal : 'c -> 'f Cmd.t -> 'f Cmd.t @@ -1729,7 +1739,6 @@ module Visitors : sig method visit_SignedRightShiftF : 'c -> BinOp.t -> BinOp.t method visit_Skip : 'c -> 'f Cmd.t -> 'f Cmd.t method visit_FreshSVar : 'c -> LCmd.t -> string -> LCmd.t - method visit_Star : 'c -> Asrt.t -> Asrt.t -> Asrt.t -> Asrt.t method visit_StrCat : 'c -> BinOp.t -> BinOp.t method visit_StrLen : 'c -> UnOp.t -> UnOp.t method visit_IntToNum : 'c -> UnOp.t -> UnOp.t @@ -1749,7 +1758,10 @@ module Visitors : sig method visit_Type : 'c -> Literal.t -> Type.t -> Literal.t method visit_TypeOf : 'c -> UnOp.t -> UnOp.t method visit_TypeType : 'c -> Type.t -> Type.t - method visit_Types : 'c -> Asrt.t -> (Expr.t * Type.t) list -> Asrt.t + + method visit_Types : + 'c -> Asrt.simple -> (Expr.t * Type.t) list -> Asrt.simple + method visit_UNot : 'c -> UnOp.t -> UnOp.t method visit_UTCTime : 'c -> Constant.t -> Constant.t method visit_UnOp : 'c -> Expr.t -> UnOp.t -> Expr.t -> Expr.t @@ -1775,6 +1787,7 @@ module Visitors : sig method private visit_array : 'env 'a. ('env -> 'a -> 'a) -> 'env -> 'a array -> 'a array + method visit_assertion_simple : 'c -> Asrt.simple -> Asrt.simple method visit_assertion : 'c -> Asrt.t -> Asrt.t method visit_bindings : @@ -1905,7 +1918,7 @@ module Visitors : sig (string * (string * Expr.t) list) option -> 'f ; visit_ForAll : 'c -> (string * Type.t option) list -> Formula.t -> 'f - ; visit_GA : 'c -> string -> Expr.t list -> Expr.t list -> 'f + ; visit_CorePred : 'c -> string -> Expr.t list -> Expr.t list -> 'f ; visit_Wand : 'c -> string * Expr.t list -> string * Expr.t list -> 'f ; visit_GUnfold : 'c -> string -> 'f ; visit_Goto : 'c -> 'g -> 'f @@ -2003,7 +2016,6 @@ module Visitors : sig ; visit_SignedRightShiftF : 'c -> 'f ; visit_Skip : 'c -> 'f ; visit_FreshSVar : 'c -> string -> 'f - ; visit_Star : 'c -> Asrt.t -> Asrt.t -> 'f ; visit_StrCat : 'c -> 'f ; visit_StrLen : 'c -> 'f ; visit_IntToNum : 'c -> 'f @@ -2045,6 +2057,7 @@ module Visitors : sig ; visit_UnsignedRightShift : 'c -> 'f ; visit_UnsignedRightShiftL : 'c -> 'f ; visit_UnsignedRightShiftF : 'c -> 'f + ; visit_assertion_simple : 'c -> Asrt.simple -> 'f ; visit_assertion : 'c -> Asrt.t -> 'f ; visit_bindings : 'c -> string * (string * Expr.t) list -> 'f ; visit_binop : 'c -> BinOp.t -> 'f @@ -2143,7 +2156,7 @@ module Visitors : sig 'f method visit_ForAll : 'c -> (string * Type.t option) list -> Formula.t -> 'f - method visit_GA : 'c -> string -> Expr.t list -> Expr.t list -> 'f + method visit_CorePred : 'c -> string -> Expr.t list -> Expr.t list -> 'f method visit_Wand : 'c -> string * Expr.t list -> string * Expr.t list -> 'f method visit_GUnfold : 'c -> string -> 'f method visit_Goto : 'c -> 'g -> 'f @@ -2241,7 +2254,6 @@ module Visitors : sig method visit_SignedRightShiftF : 'c -> 'f method visit_Skip : 'c -> 'f method visit_FreshSVar : 'c -> string -> 'f - method visit_Star : 'c -> Asrt.t -> Asrt.t -> 'f method visit_StrCat : 'c -> 'f method visit_StrLen : 'c -> 'f method visit_IntToNum : 'c -> 'f @@ -2281,6 +2293,7 @@ module Visitors : sig method visit_UnsignedRightShift : 'c -> 'f method visit_UnsignedRightShiftL : 'c -> 'f method visit_UnsignedRightShiftF : 'c -> 'f + method visit_assertion_simple : 'c -> Asrt.simple -> 'f method visit_assertion : 'c -> Asrt.t -> 'f method visit_bindings : 'c -> string * (string * Expr.t) list -> 'f method visit_binop : 'c -> BinOp.t -> 'f @@ -2382,7 +2395,7 @@ module Visitors : sig unit ; visit_ForAll : 'c -> (string * Type.t option) list -> Formula.t -> unit - ; visit_GA : 'c -> string -> Expr.t list -> Expr.t list -> unit + ; visit_CorePred : 'c -> string -> Expr.t list -> Expr.t list -> unit ; visit_Wand : 'c -> string * Expr.t list -> string * Expr.t list -> unit ; visit_GUnfold : 'c -> string -> unit @@ -2479,7 +2492,6 @@ module Visitors : sig ; visit_SignedRightShiftF : 'c -> unit ; visit_Skip : 'c -> unit ; visit_FreshSVar : 'c -> string -> unit - ; visit_Star : 'c -> Asrt.t -> Asrt.t -> unit ; visit_StrCat : 'c -> unit ; visit_StrLen : 'c -> unit ; visit_IntToNum : 'c -> unit @@ -2517,6 +2529,7 @@ module Visitors : sig ; visit_UnsignedRightShift : 'c -> unit ; visit_UnsignedRightShiftL : 'c -> unit ; visit_UnsignedRightShiftF : 'c -> unit + ; visit_assertion_simple : 'c -> Asrt.simple -> unit ; visit_assertion : 'c -> Asrt.t -> unit ; visit_bindings : 'c -> string * (string * Expr.t) list -> unit ; visit_binop : 'c -> BinOp.t -> unit @@ -2622,7 +2635,7 @@ module Visitors : sig method visit_ForAll : 'c -> (string * Type.t option) list -> Formula.t -> unit - method visit_GA : 'c -> string -> Expr.t list -> Expr.t list -> unit + method visit_CorePred : 'c -> string -> Expr.t list -> Expr.t list -> unit method visit_Wand : 'c -> string * Expr.t list -> string * Expr.t list -> unit @@ -2721,7 +2734,6 @@ module Visitors : sig method visit_SignedRightShiftF : 'c -> unit method visit_Skip : 'c -> unit method visit_FreshSVar : 'c -> string -> unit - method visit_Star : 'c -> Asrt.t -> Asrt.t -> unit method visit_StrCat : 'c -> unit method visit_StrLen : 'c -> unit method visit_IntToNum : 'c -> unit @@ -2766,6 +2778,7 @@ module Visitors : sig method private visit_array : 'env 'a. ('env -> 'a -> unit) -> 'env -> 'a array -> unit + method visit_assertion_simple : 'c -> Asrt.simple -> unit method visit_assertion : 'c -> Asrt.t -> unit method visit_bindings : 'c -> string * (string * Expr.t) list -> unit method visit_binop : 'c -> BinOp.t -> unit diff --git a/GillianCore/GIL_Syntax/Lemma.ml b/GillianCore/GIL_Syntax/Lemma.ml index ad40a132..e8b64706 100644 --- a/GillianCore/GIL_Syntax/Lemma.ml +++ b/GillianCore/GIL_Syntax/Lemma.ml @@ -50,8 +50,8 @@ let pp fmt lemma = let parameter_types (preds : (string, Pred.t) Hashtbl.t) (lemma : t) : t = (* copied from spec - needs refactoring *) let pt_asrt (a : Asrt.t) : Asrt.t = - let f_a_after a : Asrt.t = - match (a : Asrt.t) with + let f_a_after (a : Asrt.simple) : Asrt.t = + match a with | Pred (name, les) -> let pred = try Hashtbl.find preds name @@ -74,10 +74,10 @@ let parameter_types (preds : (string, Pred.t) Hashtbl.t) (lemma : t) : t = with Invalid_argument _ -> Fmt.failwith "Invalid number of arguments: %a.\nInside of lemma: %s" - Asrt.pp a lemma.lemma_name) + Asrt.simple_pp a lemma.lemma_name) in - Star (Types ac_types, a) - | _ -> a + [ Types ac_types; a ] + | _ -> [ a ] in Asrt.map None (Some f_a_after) None None a in @@ -99,8 +99,5 @@ let add_param_bindings (lemma : t) = (fun pv lv -> Asrt.Pure (Eq (PVar pv, LVar lv))) params lvar_params in - let param_eqs = Asrt.star param_eqs in - let add_to_spec spec = - { spec with lemma_hyp = Asrt.Star (param_eqs, spec.lemma_hyp) } - in + let add_to_spec spec = { spec with lemma_hyp = param_eqs @ spec.lemma_hyp } in { lemma with lemma_specs = List.map add_to_spec lemma.lemma_specs } diff --git a/GillianCore/GIL_Syntax/Pred.ml b/GillianCore/GIL_Syntax/Pred.ml index 32a39b63..fe8f0ef6 100644 --- a/GillianCore/GIL_Syntax/Pred.ml +++ b/GillianCore/GIL_Syntax/Pred.ml @@ -183,8 +183,8 @@ let check_pvars (predicates : (string, t) Hashtbl.t) : unit = *) let explicit_param_types (preds : (string, t) Hashtbl.t) (pred : t) : t = let pt_asrt (a : Asrt.t) : Asrt.t = - let f_a_after a : Asrt.t = - match (a : Asrt.t) with + let f_a_after (a : Asrt.simple) : Asrt.t = + match a with | Pred (name, les) -> let pred = try Hashtbl.find preds name @@ -219,8 +219,8 @@ let explicit_param_types (preds : (string, t) Hashtbl.t) (pred : t) : t = | Some t_x -> (le, t_x) :: ac_types) [] combined in - Star (Types ac_types, a) - | _ -> a + [ Types ac_types; a ] + | _ -> [ a ] in Asrt.map None (Some f_a_after) None None a in @@ -235,7 +235,7 @@ let explicit_param_types (preds : (string, t) Hashtbl.t) (pred : t) : t = in let new_defs = List.map - (fun (oid, a) -> (oid, pt_asrt (Asrt.star (a :: new_asrts)))) + (fun (oid, a) -> (oid, pt_asrt (a @ new_asrts))) pred.pred_definitions in let new_facts = @@ -326,7 +326,7 @@ let close_token_call (pred : t) : Asrt.t = let args = in_args pred pred.pred_params |> List.map (fun (x, _t) -> Expr.PVar x) in - Asrt.Pred (name, args) + [ Asrt.Pred (name, args) ] (* Given a name, if it's a close_token name, returns the name of the corresponding predicate, otherwise return None. *) diff --git a/GillianCore/GIL_Syntax/Spec.ml b/GillianCore/GIL_Syntax/Spec.ml index f9350355..78f33a71 100644 --- a/GillianCore/GIL_Syntax/Spec.ml +++ b/GillianCore/GIL_Syntax/Spec.ml @@ -77,8 +77,8 @@ let pp fmt spec = let parameter_types (preds : (string, Pred.t) Hashtbl.t) (spec : t) : t = let pt_asrt (a : Asrt.t) : Asrt.t = - let f_a_after a : Asrt.t = - match (a : Asrt.t) with + let f_a_after (a : Asrt.simple) : Asrt.t = + match a with | Pred (name, les) -> let pred = try Hashtbl.find preds name @@ -110,8 +110,8 @@ let parameter_types (preds : (string, Pred.t) Hashtbl.t) (spec : t) : t = | Some t_x -> (le, t_x) :: ac_types) [] combined_params in - Star (Types ac_types, a) - | _ -> a + [ Types ac_types; a ] + | _ -> [ a ] in Asrt.map None (Some f_a_after) None None a in diff --git a/GillianCore/GIL_Syntax/TypeDef__.ml b/GillianCore/GIL_Syntax/TypeDef__.ml index 0ae9811b..49473e46 100644 --- a/GillianCore/GIL_Syntax/TypeDef__.ml +++ b/GillianCore/GIL_Syntax/TypeDef__.ml @@ -162,15 +162,15 @@ and formula = | ForAll of (string * typ option) list * formula | IsInt of expr -and assertion = +and assertion_simple = | Emp - | Star of assertion * assertion | Pred of string * expr list | Pure of formula | Types of (expr * typ) list - | GA of string * expr list * expr list + | CorePred of string * expr list * expr list | Wand of { lhs : string * expr list; rhs : string * expr list } +and assertion = assertion_simple list and bindings = string * (string * expr) list and slcmd = diff --git a/GillianCore/gil_parser/GIL_Parser.mly b/GillianCore/gil_parser/GIL_Parser.mly index 81ab250f..1495efd8 100644 --- a/GillianCore/gil_parser/GIL_Parser.mly +++ b/GillianCore/gil_parser/GIL_Parser.mly @@ -129,7 +129,7 @@ let normalised_lvar_r = Str.regexp "##NORMALISED_LVAR" %token ASSERT %token SEPASSERT %token INVARIANT -%token CONSUME +%token CONSUME %token PRODUCE %token ASSUME_TYPE %token LSTNTH @@ -699,30 +699,30 @@ g_assertion_target: (* P * Q *) (* The precedence of the separating conjunction is not the same as the arithmetic product *) | left_ass=g_assertion_target; FTIMES; right_ass=g_assertion_target - { Asrt.Star (left_ass, right_ass) } %prec separating_conjunction + { left_ass @ right_ass } %prec separating_conjunction | lhs = predicate_call; WAND; rhs = predicate_call - { Asrt.Wand {lhs; rhs } } %prec magic_wand -(* (es; es) *) + { [ Asrt.Wand {lhs; rhs } ] } %prec magic_wand +(* (es; es) *) | FLT; v=VAR; FGT; LBRACE; es1=separated_list(COMMA, expr_target); SCOLON; es2=separated_list(COMMA, expr_target); RBRACE - { Asrt.GA (v, es1, es2) } + { [ Asrt.CorePred (v, es1, es2) ] } (* emp *) | LEMP; - { Asrt.Emp } + { [ Asrt.Emp ] } (* x(e1, ..., en) *) | pcall = predicate_call - { + { let (name, params) = pcall in - Asrt.Pred (name, params) + [ Asrt.Pred (name, params) ] } (* types (type_pairs) *) | LTYPES; LBRACE; type_pairs = separated_list(COMMA, type_env_pair_target); RBRACE - { Asrt.Types type_pairs } + { [ Asrt.Types type_pairs ] } (* (P) *) | LBRACE; g_assertion_target; RBRACE { $2 } (* pure *) | pure_assertion_target - { Asrt.Pure $1 } + { [ Asrt.Pure $1 ] } ; g_macro_target: @@ -752,7 +752,7 @@ g_logic_cmd_target: (* unfold* x(e1, ..., en) [ def with #x := le1 and ... ] *) | RECUNFOLD; name = proc_name; LBRACE; les=separated_list(COMMA, expr_target); RBRACE; unfold_info = option(unfold_info_target) { LCmd.SL (Unfold (name, les, unfold_info, true)) } - + | PACKAGE; LBRACE; lhs = predicate_call; WAND; rhs = predicate_call; RBRACE; { LCmd.SL (Package { lhs; rhs })} @@ -765,10 +765,10 @@ g_logic_cmd_target: (* invariant (a) [existentials: x, y, z] *) | INVARIANT; LBRACE; a = g_assertion_target; RBRACE; binders = option(binders_target) { LCmd.SL (Invariant (a, Option.value ~default:[ ] binders)) } - + | CONSUME; LBRACE; a = g_assertion_target; RBRACE; binders = option(binders_target) { LCmd.SL (Consume (a, Option.value ~default:[ ] binders)) } - + | PRODUCE; LBRACE; a = g_assertion_target; RBRACE; { LCmd.SL (Produce a) } From 2a8672a431a8bcb5401bf955a79137e2ecb88bc2 Mon Sep 17 00:00:00 2001 From: N1ark Date: Sun, 15 Sep 2024 22:06:41 +0100 Subject: [PATCH 02/54] This compiles somehow --- Gillian-C/lib/Constr.ml | 2 +- Gillian-C/lib/SHeapTree.mli | 2 +- Gillian-C/lib/gil_logic_gen.ml | 124 +++++++------- Gillian-JS/lib/Compiler/JSIL2GIL.ml | 17 +- Gillian-JS/lib/Semantics/JSILSMemory.ml | 51 +++--- Gillian-JS/lib/Semantics/SFVL.ml | 4 +- Gillian-JS/lib/Semantics/SFVL.mli | 2 +- Gillian-JS/lib/Semantics/SHeap.ml | 5 +- Gillian-JS/lib/utils/asrt_utils.ml | 6 +- GillianCore/GIL_Syntax/Asrt.ml | 8 +- GillianCore/GIL_Syntax/Gil_syntax.mli | 4 + GillianCore/GIL_Syntax/Lemma.ml | 2 +- GillianCore/debugging/utils/match_map.ml | 2 +- .../engine/Abstraction/LogicPreprocessing.ml | 158 ++++++++++-------- GillianCore/engine/Abstraction/MP.ml | 91 +++++----- GillianCore/engine/Abstraction/MP.mli | 20 +-- GillianCore/engine/Abstraction/Matcher.ml | 47 +++--- GillianCore/engine/Abstraction/Matcher.mli | 6 +- GillianCore/engine/Abstraction/Normaliser.ml | 64 +++---- GillianCore/engine/Abstraction/PState.ml | 16 +- GillianCore/engine/Abstraction/Preds.ml | 2 +- GillianCore/engine/Abstraction/Preds.mli | 2 +- GillianCore/engine/Abstraction/Verifier.ml | 4 +- GillianCore/engine/BiAbduction/Abductor.ml | 12 +- GillianCore/engine/BiAbduction/BiState.ml | 10 +- GillianCore/engine/FOLogic/Reduction.ml | 101 ++++++----- GillianCore/engine/FOLogic/Simplifications.ml | 8 +- .../engine/concrete_semantics/CState.ml | 4 +- GillianCore/engine/general_semantics/state.ml | 4 +- .../engine/general_semantics/stateErr.ml | 6 +- .../symbolic_semantics/Legacy_s_memory.ml | 4 +- .../engine/symbolic_semantics/SMemory.ml | 4 +- .../engine/symbolic_semantics/SState.ml | 16 +- GillianCore/monadic/MonadicSMemory.ml | 6 +- kanillian/lib/compiler/logics.ml | 20 +-- kanillian/lib/memory_model/GEnv.mli | 4 +- kanillian/lib/memory_model/SHeapTree.mli | 2 +- kanillian/lib/memory_model/predicates.ml | 2 +- wisl/lib/ParserAndCompiler/wisl2Gil.ml | 35 ++-- wisl/lib/semantics/constr.ml | 6 +- wisl/lib/semantics/wislSHeap.mli | 2 +- wisl/lib/semantics/wislSMemory.ml | 2 +- 42 files changed, 440 insertions(+), 447 deletions(-) diff --git a/Gillian-C/lib/Constr.ml b/Gillian-C/lib/Constr.ml index e630e942..979a04b6 100644 --- a/Gillian-C/lib/Constr.ml +++ b/Gillian-C/lib/Constr.ml @@ -3,7 +3,7 @@ open Gil_syntax module Core = struct let pred ga ins outs = let ga_name = LActions.str_ga ga in - Asrt.GA (ga_name, ins, outs) + Asrt.CorePred (ga_name, ins, outs) let single ~loc ~ofs ~chunk ~sval ~perm = let chunk = Expr.Lit (String (ValueTranslation.string_of_chunk chunk)) in diff --git a/Gillian-C/lib/SHeapTree.mli b/Gillian-C/lib/SHeapTree.mli index 2936bfb9..230f1a5a 100644 --- a/Gillian-C/lib/SHeapTree.mli +++ b/Gillian-C/lib/SHeapTree.mli @@ -85,7 +85,7 @@ val allocated_function : t [dst_tree] after modification *) val move : t -> Expr.t -> t -> Expr.t -> Expr.t -> t d_or_error -val assertions : loc:string -> t -> Asrt.t list +val assertions : loc:string -> t -> Asrt.t val substitution : le_subst:(Expr.t -> Expr.t) -> diff --git a/Gillian-C/lib/gil_logic_gen.ml b/Gillian-C/lib/gil_logic_gen.ml index 0ba80016..4393c844 100644 --- a/Gillian-C/lib/gil_logic_gen.ml +++ b/Gillian-C/lib/gil_logic_gen.ml @@ -5,7 +5,6 @@ open CLogic open Compcert open CompileState module Str_set = Gillian.Utils.Containers.SS -open Asrt.Infix open Formula.Infix module CoreP = Constr.Core @@ -163,7 +162,7 @@ let assert_of_member cenv members id typ = in let args = pvloc :: ofs :: args_without_ins in let pred_call = Asrt.Pred (pred_name, args) in - list_is_components ** pred_call + [ list_is_components; pred_call ] else if match typ with | Tarray _ -> true @@ -181,8 +180,10 @@ let assert_of_member cenv members id typ = | Some chunk -> chunk | _ -> failwith "Array in a structure containing complicated types" in - Constr.Core.array ~loc:pvloc ~ofs:(pvofs ++ fo) ~chunk ~size:n_e - ~sval_arr:pvmember ~perm:(Some Freeable) + [ + Constr.Core.array ~loc:pvloc ~ofs:(pvofs ++ fo) ~chunk ~size:n_e + ~sval_arr:pvmember ~perm:(Some Freeable); + ] else let mk t v = Expr.list [ Expr.string t; v ] in let field_val_name = "#i__" ^ field_name ^ "_v" in @@ -211,7 +212,7 @@ let assert_of_member cenv members id typ = CoreP.single ~loc:pvloc ~ofs:(pvofs ++ fo) ~chunk ~sval:e_to_use ~perm:(Some Freeable) in - getter_or_type_pred ** ga_asrt + [ getter_or_type_pred; ga_asrt ] let assert_of_hole (low, high) = let pvloc = Expr.PVar loc_param_name in @@ -257,9 +258,9 @@ let gen_pred_of_struct cenv ann struct_name = (fun asrt member -> match member with | Member_plain (id, typ) -> - asrt ** assert_of_member cenv comp.co_members id typ + asrt @ assert_of_member cenv comp.co_members id typ | Member_bitfield _ -> failwith "Unsupported bitfield members") - Asrt.Emp comp.co_members + [] comp.co_members in let fo idp = match field_offset cenv idp comp.co_members with @@ -284,7 +285,7 @@ let gen_pred_of_struct cenv ann struct_name = let holes = get_holes comp.co_members in let holes_asserts = List.map assert_of_hole holes in - let def = Asrt.star holes_asserts ** def_without_holes in + let def = holes_asserts @ def_without_holes in (* TODO (Alexis): How to handle changes in structs? *) let n_pred = Pred. @@ -354,29 +355,29 @@ let trans_sval (sv : CSVal.t) : Asrt.t * Var.t list * Expr.t = match sv with | CSVal.Sint se -> let eg = tse se in - (tint eg, [], mk int_type (tse se)) + ([ tint eg ], [], mk int_type (tse se)) | Slong se -> let eg = tse se in - (tint eg, [], mk long_type (tse se)) + ([ tint eg ], [], mk long_type (tse se)) | Ssingle se -> let eg = tse se in - (tnum eg, [], mk single_type (tse se)) + ([ tnum eg ], [], mk single_type (tse se)) | Sfloat se -> let eg = tse se in - (tnum eg, [], mk float_type (tse se)) + ([ tnum eg ], [], mk float_type (tse se)) | Sptr (se1, se2) -> let eg1, eg2 = (tse se1, tse se2) in - (tloc eg1 ** tint eg2, [], Expr.EList [ tse se1; tse se2 ]) + ([ tloc eg1; tint eg2 ], [], Expr.EList [ tse se1; tse se2 ]) | Sfunptr symb -> let loc = Global_env.location_of_symbol symb in let ptr = Expr.EList [ Lit (Loc loc); Expr.zero_i ] in - (Asrt.Emp, [], ptr) + ([], [], ptr) (** Returns assertions that are necessary to define the expression, the created variable for binding when necessary, and the used expression *) let rec trans_expr (e : CExpr.t) : Asrt.t * Var.t list * Expr.t = match e with - | CExpr.SExpr se -> (Asrt.Emp, [], trans_simpl_expr se) + | CExpr.SExpr se -> ([], [], trans_simpl_expr se) | SVal sv -> trans_sval sv | EList el -> let asrts, vars, elp = split3_expr_comp (List.map trans_expr el) in @@ -389,27 +390,27 @@ let rec trans_expr (e : CExpr.t) : Asrt.t * Var.t list * Expr.t = | BinOp (e1, LstCat, e2) -> let a1, v1, eg1 = trans_expr e1 in let a2, v2, eg2 = trans_expr e2 in - (a1 ** a2, v1 @ v2, Expr.list_cat eg1 eg2) + (a1 @ a2, v1 @ v2, Expr.list_cat eg1 eg2) | BinOp (e1, LstCons, e2) -> let a1, v1, eg1 = trans_expr e1 in let a2, v2, eg2 = trans_expr e2 in - (a1 ** a2, v1 @ v2, Expr.list_cat (EList [ eg1 ]) eg2) + (a1 @ a2, v1 @ v2, Expr.list_cat (EList [ eg1 ]) eg2) | BinOp (e1, PtrPlus, e2) -> ( let a1, v1, ptr = trans_expr e1 in let a2, v2, to_add = trans_expr e2 in match ptr with | Expr.EList [ loc; ofs ] -> - (a1 ** a2, v1 @ v2, Expr.EList [ loc; Expr.Infix.( + ) ofs to_add ]) + (a1 @ a2, v1 @ v2, Expr.EList [ loc; Expr.Infix.( + ) ofs to_add ]) | ptr -> let res_lvar = fresh_lvar () in let res = Expr.LVar res_lvar in - ( a1 ** a2 ** Constr.Others.ptr_add ~ptr ~to_add ~res, + ( [ Constr.Others.ptr_add ~ptr ~to_add ~res ] @ a1 @ a2, res_lvar :: (v1 @ v2), res )) | BinOp (e1, b, e2) -> let a1, v1, eg1 = trans_expr e1 in let a2, v2, eg2 = trans_expr e2 in - (a1 ** a2, v1 @ v2, BinOp (eg1, trans_binop b, eg2)) + (a1 @ a2, v1 @ v2, BinOp (eg1, trans_binop b, eg2)) | UnOp (u, e) -> let a, v, eg = trans_expr e in (a, v, UnOp (trans_unop u, eg)) @@ -422,44 +423,44 @@ let rec trans_expr (e : CExpr.t) : Asrt.t * Var.t list * Expr.t = let a1, v1, lst = trans_expr lst in let a2, v2, start = trans_expr start in let a3, v3, len = trans_expr len in - (a1 ** a2 ** a3, v1 @ v2 @ v3, Expr.list_sub ~lst ~start ~size:len) + (a1 @ a2 @ a3, v1 @ v2 @ v3, Expr.list_sub ~lst ~start ~size:len) let rec trans_form (f : CFormula.t) : Asrt.t * Var.t list * Formula.t = let open Formula.Infix in match f with - | CFormula.True -> (Emp, [], Formula.True) - | False -> (Emp, [], False) + | CFormula.True -> ([], [], Formula.True) + | False -> ([], [], False) | Eq (ce1, ce2) -> let f1, v1, eg1 = trans_expr ce1 in let f2, v2, eg2 = trans_expr ce2 in - (f1 ** f2, v1 @ v2, eg1 #== eg2) + (f1 @ f2, v1 @ v2, eg1 #== eg2) | LessEq (ce1, ce2) -> let f1, v1, eg1 = trans_expr ce1 in let f2, v2, eg2 = trans_expr ce2 in - (f1 ** f2, v1 @ v2, eg1 #<= eg2) + (f1 @ f2, v1 @ v2, eg1 #<= eg2) | Less (ce1, ce2) -> let f1, v1, eg1 = trans_expr ce1 in let f2, v2, eg2 = trans_expr ce2 in - (f1 ** f2, v1 @ v2, eg1 #< eg2) + (f1 @ f2, v1 @ v2, eg1 #< eg2) | SetMem (ce1, ce2) -> let f1, v1, eg1 = trans_expr ce1 in let f2, v2, eg2 = trans_expr ce2 in - (f1 ** f2, v1 @ v2, SetMem (eg1, eg2)) + (f1 @ f2, v1 @ v2, SetMem (eg1, eg2)) | Not fp -> let a, v, fpp = trans_form fp in (a, v, fnot fpp) | Or (f1, f2) -> let a1, v1, fp1 = trans_form f1 in let a2, v2, fp2 = trans_form f2 in - (a1 ** a2, v1 @ v2, fp1 #|| fp2) + (a1 @ a2, v1 @ v2, fp1 #|| fp2) | And (f1, f2) -> let a1, v1, fp1 = trans_form f1 in let a2, v2, fp2 = trans_form f2 in - (a1 ** a2, v1 @ v2, fp1 #&& fp2) + (a1 @ a2, v1 @ v2, fp1 #&& fp2) | Implies (f1, f2) -> let a1, v1, fp1 = trans_form f1 in let a2, v2, fp2 = trans_form f2 in - (a1 ** a2, v1 @ v2, fp1 #=> fp2) + (a1 @ a2, v1 @ v2, fp1 #=> fp2) | ForAll (lvts, f) -> let a, v, fp = trans_form f in (a, v, ForAll (lvts, fp)) @@ -511,13 +512,13 @@ let trans_constr ?fname:_ ~(typ : CAssert.points_to_type) ann s c = let loc = Global_env.location_of_symbol symb in let loc = Expr.Lit (Loc loc) in let ofsv = Expr.int 0 in - (Asrt.Emp, loc, ofsv) + ([], loc, ofsv) | _ -> let a_s, _, s_e = trans_expr s in let locv = gen_loc_var () in let ofsv = gen_ofs_var () in let pc = ptr_call s_e locv ofsv in - (pc ** a_s, locv, ofsv) + (pc :: a_s, locv, ofsv) in let to_assert, locv, ofsv = interpret_s ~typ s in let malloc_chunk siz = @@ -534,7 +535,7 @@ let trans_constr ?fname:_ ~(typ : CAssert.points_to_type) ann s c = let ga = CoreP.single ~loc:locv ~ofs:ofsv ~chunk ~sval:sv ~perm:(Some Freeable) in - ga ** to_assert ** tint e ** malloc_chunk siz + [ ga; tint e; malloc_chunk siz ] @ to_assert | ConsExpr (SVal (Sfloat se)) -> let e = cse se in let chunk = Chunk.Mfloat32 in @@ -543,7 +544,7 @@ let trans_constr ?fname:_ ~(typ : CAssert.points_to_type) ann s c = let ga = CoreP.single ~loc:locv ~ofs:ofsv ~chunk ~sval:sv ~perm:(Some Freeable) in - ga ** to_assert ** tnum e ** malloc_chunk siz + [ ga; tnum e; malloc_chunk siz ] @ to_assert | ConsExpr (SVal (Ssingle se)) -> let e = cse se in let chunk = Chunk.Mfloat32 in @@ -552,7 +553,7 @@ let trans_constr ?fname:_ ~(typ : CAssert.points_to_type) ann s c = let ga = CoreP.single ~loc:locv ~ofs:ofsv ~chunk ~sval:sv ~perm:(Some Freeable) in - ga ** to_assert ** tnum e ** malloc_chunk siz + [ ga; tnum e; malloc_chunk siz ] @ to_assert | ConsExpr (SVal (Slong se)) -> let e = cse se in let chunk = Chunk.Mint64 in @@ -561,7 +562,7 @@ let trans_constr ?fname:_ ~(typ : CAssert.points_to_type) ann s c = let ga = CoreP.single ~loc:locv ~ofs:ofsv ~chunk ~sval:sv ~perm:(Some Freeable) in - ga ** to_assert ** tint e ** malloc_chunk siz + [ ga; tint e; malloc_chunk siz ] @ to_assert | ConsExpr (SVal (Sptr (sl, so))) -> let l = cse sl in let o = cse so in @@ -571,7 +572,7 @@ let trans_constr ?fname:_ ~(typ : CAssert.points_to_type) ann s c = let ga = CoreP.single ~loc:locv ~ofs:ofsv ~chunk ~sval:sv ~perm:(Some Freeable) in - ga ** to_assert ** tloc l ** tint o ** malloc_chunk siz + [ ga; tloc l; tint o; malloc_chunk siz ] @ to_assert | ConsExpr (SVal (Sfunptr fname)) -> let l = Global_env.location_of_symbol fname in let ptr = Expr.EList [ Expr.Lit (Loc l); Expr.zero_i ] in @@ -580,7 +581,7 @@ let trans_constr ?fname:_ ~(typ : CAssert.points_to_type) ann s c = let ga_single = CoreP.single ~loc:locv ~ofs:ofsv ~chunk ~sval:ptr ~perm:(Some Freeable) in - ga_single ** to_assert ** malloc_chunk siz + [ ga_single; malloc_chunk siz ] @ to_assert | ConsExpr _ -> Fmt.failwith "Constructor %a is not handled yet" CConstructor.pp c | ConsStruct (sname, el) -> @@ -598,14 +599,14 @@ let trans_constr ?fname:_ ~(typ : CAssert.points_to_type) ann s c = in let pr = Asrt.Pred (struct_pred, [ locv; ofsv ] @ params_fields) - ** Asrt.star more_asrt + :: Asrt.star more_asrt in - pr ** to_assert ** malloc_chunk siz + [ malloc_chunk siz ] @ pr @ to_assert let rec trans_asrt ~fname ~ann asrt = match asrt with | CAssert.Star (a1, a2) -> - trans_asrt ~fname ~ann a1 ** trans_asrt ~fname ~ann a2 + trans_asrt ~fname ~ann a1 @ trans_asrt ~fname ~ann a2 | Array { ptr; chunk; size; content; malloced } -> let a1, _, ptr = trans_expr ptr in let a2, _, size = trans_expr size in @@ -615,38 +616,38 @@ let rec trans_asrt ~fname ~ann asrt = let open Expr.Infix in let csize = Expr.int (Chunk.size chunk) in let total_size = size * csize in - Constr.Others.malloced_abst ~ptr ~total_size - else Asrt.Emp + [ Constr.Others.malloced_abst ~ptr ~total_size ] + else [] in - a1 ** a2 ** a3 - ** Constr.Others.array_ptr ~ptr ~chunk ~size ~content - ** malloc_p + a1 @ a2 @ a3 + @ [ Constr.Others.array_ptr ~ptr ~chunk ~size ~content ] + @ malloc_p | Malloced (e1, e2) -> let a1, _, ce1 = trans_expr e1 in let a2, _, ce2 = trans_expr e2 in - a1 ** a2 ** Constr.Others.malloced_abst ~ptr:ce1 ~total_size:ce2 + a1 @ a2 @ [ Constr.Others.malloced_abst ~ptr:ce1 ~total_size:ce2 ] | Zeros (e1, e2) -> let a1, _, ce1 = trans_expr e1 in let a2, _, ce2 = trans_expr e2 in - a1 ** a2 ** Constr.Others.zeros_ptr_size ~ptr:ce1 ~size:ce2 + a1 @ a2 @ [ Constr.Others.zeros_ptr_size ~ptr:ce1 ~size:ce2 ] | Undefs (e1, e2) -> let a1, _, ce1 = trans_expr e1 in let a2, _, ce2 = trans_expr e2 in - a1 ** a2 ** Constr.Others.undefs_ptr_size ~ptr:ce1 ~size:ce2 + a1 @ a2 @ [ Constr.Others.undefs_ptr_size ~ptr:ce1 ~size:ce2 ] | Pure f -> let ma, _, fp = trans_form f in - ma ** Pure fp + Pure fp :: ma | Pred (p, cel) -> let ap, _, gel = split3_expr_comp (List.map trans_expr cel) in - Asrt.star ap ** Pred (p, gel) - | Emp -> Emp + Pred (p, gel) :: Asrt.star ap + | Emp -> [] | PointsTo { ptr = s; constr = c; typ } -> trans_constr ~fname ~typ ann s c let rec trans_lcmd ~fname ~ann lcmd = let trans_lcmd = trans_lcmd ~fname ~ann in let trans_asrt = trans_asrt ~fname ~ann in let make_assert ~bindings = function - | Asrt.Emp -> [] + | [] -> [] | a -> [ LCmd.SL (SepAssert (a, bindings)) ] in match lcmd with @@ -696,7 +697,7 @@ let trans_asrt_annot da = | Some t -> (ex, types t (Expr.LVar ex))) existentials) in - let a = Asrt.star typsb in + let a = typsb in (a, (label, exs)) let trans_abs_pred ~filepath cl_pred = @@ -747,7 +748,7 @@ let trans_pred ~ann ~filepath cl_pred = | None -> (None, trans_asrt ~fname:pred_name ~ann a) | Some da -> let ada, gda = trans_asrt_annot da in - (Some gda, ada ** trans_asrt ~fname:pred_name ~ann a)) + (Some gda, ada @ trans_asrt ~fname:pred_name ~ann a)) definitions in Pred. @@ -778,7 +779,7 @@ let trans_sspec ~ann fname sspecs = let CSpec.{ pre; posts; spec_annot } = sspecs in let tap, spa = match spec_annot with - | None -> (Asrt.Emp, None) + | None -> ([], None) | Some spa -> let a, (label, exs) = trans_asrt_annot spa in (a, Some (label, exs)) @@ -787,7 +788,7 @@ let trans_sspec ~ann fname sspecs = let make_post p = if !Config.allocated_functions then ta p else ta p in Spec. { - ss_pre = tap ** ta pre; + ss_pre = tap @ ta pre; ss_posts = List.map make_post posts; (* FIXME: bring in variant *) ss_variant = None; @@ -965,16 +966,15 @@ let generate_bispec clight_prog fname ident f = let mk_lvar x = Expr.LVar ("#" ^ x) in let lvars = List.map mk_lvar true_params in let equalities = - Asrt.star - (List.map - (fun x -> Asrt.Pure (Formula.Eq (Expr.PVar x, mk_lvar x))) - true_params) + List.map + (fun x -> Asrt.Pure (Formula.Eq (Expr.PVar x, mk_lvar x))) + true_params in (* Right now, triples are : (param_name, csharpminor type, c type) The C type will be used to discriminate long/int from pointers *) let triples = combine lvars sig_args cligh_params in let pred_list = List.map predicate_from_triple triples in - let pre = equalities ** Asrt.star pred_list in + let pre = equalities @ pred_list in BiSpec. { bispec_name = fname; diff --git a/Gillian-JS/lib/Compiler/JSIL2GIL.ml b/Gillian-JS/lib/Compiler/JSIL2GIL.ml index 24c82b45..0e7bbe44 100644 --- a/Gillian-JS/lib/Compiler/JSIL2GIL.ml +++ b/Gillian-JS/lib/Compiler/JSIL2GIL.ml @@ -98,15 +98,16 @@ let rec jsil2gil_asrt (a : Asrt.t) : GAsrt.t = let f = jsil2gil_asrt in let fe = jsil2gil_expr in match a with - | Emp -> Emp - | Star (a1, a2) -> Star (f a1, f a2) + | Emp -> [ Emp ] + | Star (a1, a2) -> f a1 @ f a2 | PointsTo (e1, e2, e3) -> - Asrt_utils.points_to ~loc:(fe e1) ~field:(fe e2) ~value:(fe e3) - | MetaData (e1, e2) -> Asrt_utils.metadata ~loc:(fe e1) ~metadata:(fe e2) - | EmptyFields (e1, e2) -> Asrt_utils.empty_fields ~loc:(fe e1) ~domain:(fe e2) - | Pred (pn, es) -> Pred (pn, List.map fe es) - | Pure f -> Pure (jsil2gil_formula f) - | Types vts -> Types (List.map (fun (v, t) -> (fe v, t)) vts) + [ Asrt_utils.points_to ~loc:(fe e1) ~field:(fe e2) ~value:(fe e3) ] + | MetaData (e1, e2) -> [ Asrt_utils.metadata ~loc:(fe e1) ~metadata:(fe e2) ] + | EmptyFields (e1, e2) -> + [ Asrt_utils.empty_fields ~loc:(fe e1) ~domain:(fe e2) ] + | Pred (pn, es) -> [ Pred (pn, List.map fe es) ] + | Pure f -> [ Pure (jsil2gil_formula f) ] + | Types vts -> [ Types (List.map (fun (v, t) -> (fe v, t)) vts) ] let jsil2gil_slcmd (slcmd : SLCmd.t) : GSLCmd.t = match slcmd with diff --git a/Gillian-JS/lib/Semantics/JSILSMemory.ml b/Gillian-JS/lib/Semantics/JSILSMemory.ml index 9cf0a69e..b2929db3 100644 --- a/Gillian-JS/lib/Semantics/JSILSMemory.ml +++ b/Gillian-JS/lib/Semantics/JSILSMemory.ml @@ -90,7 +90,7 @@ module M = struct in Recovery_tactic.try_unfold values - let assertions ?to_keep:_ (heap : t) : GAsrt.t list = SHeap.assertions heap + let assertions ?to_keep:_ (heap : t) : GAsrt.t = SHeap.assertions heap let lvars (heap : t) : Containers.SS.t = SHeap.lvars heap let alocs (heap : t) : Containers.SS.t = SHeap.alocs heap @@ -597,9 +597,7 @@ module M = struct let prop_abduce_none_in_js = [ "@call" ] let prop_abduce_both_in_js = [ "hasOwnProperty" ] - type fix_result = Asrt.t list - - let complete_fix_js (i_fix : i_fix_t) : fix_result list = + let complete_fix_js (i_fix : i_fix_t) : Asrt.t list = match i_fix with | FLoc v -> (* Get a fresh location *) @@ -610,7 +608,7 @@ module M = struct [ [ Asrt.Pure (Eq (ALoc al, v)) ] ] | FCell (l, p) -> ( let none_fix () = - [ Asrt.GA (JSILNames.aCell, [ l; p ], [ Lit Nono ]) ] + [ Asrt.CorePred (JSILNames.aCell, [ l; p ], [ Lit Nono ]) ] in let some_fix () = @@ -632,7 +630,7 @@ module M = struct ] in [ - Asrt.GA (JSILNames.aCell, [ l; p ], [ descriptor ]); + Asrt.CorePred (JSILNames.aCell, [ l; p ], [ descriptor ]); Asrt.Pure asrt_empty; Asrt.Pure asrt_none; Asrt.Pure asrt_list; @@ -651,17 +649,17 @@ module M = struct [ [ Asrt.Pure (Eq (ALoc al, l)); - Asrt.GA (JSILNames.aMetadata, [ l ], [ mloc ]); - Asrt.GA (JSILNames.aMetadata, [ mloc ], [ Lit Null ]); - Asrt.GA + Asrt.CorePred (JSILNames.aMetadata, [ l ], [ mloc ]); + Asrt.CorePred (JSILNames.aMetadata, [ mloc ], [ Lit Null ]); + Asrt.CorePred ( JSILNames.aCell, [ mloc; Lit (String "@class") ], [ Lit (String "Object") ] ); - Asrt.GA + Asrt.CorePred ( JSILNames.aCell, [ mloc; Lit (String "@extensible") ], [ Lit (Bool true) ] ); - Asrt.GA + Asrt.CorePred ( JSILNames.aCell, [ mloc; Lit (String "@proto") ], [ Lit (Loc JS2JSIL_Helpers.locObjPrototype) ] ); @@ -670,7 +668,7 @@ module M = struct | FPure f -> [ [ Asrt.Pure f ] ] (* Fix completion: simple *) - let complete_fix_jsil (i_fix : i_fix_t) : fix_result list = + let complete_fix_jsil (i_fix : i_fix_t) : Asrt.t list = match i_fix with | FLoc v -> (* Get a fresh location *) @@ -682,20 +680,29 @@ module M = struct let v : vt = LVar vvar in (* Value is not none - we always bi-abduce presence *) let not_none : Formula.t = Not (Eq (v, Lit Nono)) in - [ [ Asrt.GA (JSILNames.aCell, [ l; p ], [ v ]); Asrt.Pure not_none ] ] + [ + [ + Asrt.CorePred (JSILNames.aCell, [ l; p ], [ v ]); Asrt.Pure not_none; + ]; + ] | FMetadata l -> (* Fresh variable to denote the property value *) let vvar = LVar.alloc () in let v : vt = LVar vvar in let not_none : Formula.t = Not (Eq (v, Lit Nono)) in - [ [ Asrt.GA (JSILNames.aMetadata, [ l ], [ v ]); Asrt.Pure not_none ] ] + [ + [ + Asrt.CorePred (JSILNames.aMetadata, [ l ], [ v ]); + Asrt.Pure not_none; + ]; + ] | FPure f -> [ [ Asrt.Pure f ] ] (* An error can have multiple fixes *) - let get_fixes (err : err_t) : fix_result list = - let pp_fix_result ft res = + let get_fixes (err : err_t) : Asrt.t list = + let pp_fix ft res = let open Fmt in - pf ft "@[@[[[ %a ]]@]@\n@]" (list ~sep:comma Asrt.pp) res + pf ft "@[@[[[ %a ]]@]@\n@]" Asrt.pp res in let _, fixes, _ = err in L.verbose (fun m -> @@ -709,10 +716,10 @@ module M = struct if !Js_config.js then complete_fix_js else complete_fix_jsil in - let complete_ifixes (ifixes : i_fix_t list) : fix_result list = + let complete_ifixes (ifixes : i_fix_t list) : Asrt.t list = let completed_ifixes = List.map complete ifixes in let completed_ifixes = List_utils.list_product completed_ifixes in - let completed_ifixes : fix_result list = + let completed_ifixes : Asrt.t list = List.map (fun fixes -> List.fold_right List.append fixes []) completed_ifixes @@ -721,16 +728,14 @@ module M = struct L.verbose (fun m -> m "@[Memory: i-fixes completed: %d@\n%a" (List.length completed_ifixes) - Fmt.(list ~sep:(any "@\n") pp_fix_result) + Fmt.(list ~sep:(any "@\n") pp_fix) completed_ifixes); completed_ifixes in (* Fixes hold lists of lists of i_fixes, *) - let completed_fixes = List.concat (List.map complete_ifixes fixes) in - - completed_fixes + List.concat_map complete_ifixes fixes let can_fix _ = true diff --git a/Gillian-JS/lib/Semantics/SFVL.ml b/Gillian-JS/lib/Semantics/SFVL.ml index 610d9949..9231e48d 100644 --- a/Gillian-JS/lib/Semantics/SFVL.ml +++ b/Gillian-JS/lib/Semantics/SFVL.ml @@ -75,10 +75,10 @@ let alocs (sfvl : t) : SS.t = SS.union ac (SS.union (Expr.alocs e_field) (Expr.alocs e_val))) sfvl SS.empty -let assertions (loc : Expr.t) (sfvl : t) : Asrt.t list = +let assertions (loc : Expr.t) (sfvl : t) : Asrt.t = List.rev (Expr.Map.fold - (fun field value (ac : Asrt.t list) -> + (fun field value (ac : Asrt.t) -> Asrt_utils.points_to ~loc ~field ~value :: ac) sfvl []) diff --git a/Gillian-JS/lib/Semantics/SFVL.mli b/Gillian-JS/lib/Semantics/SFVL.mli index 2a4cdee4..3427ed05 100644 --- a/Gillian-JS/lib/Semantics/SFVL.mli +++ b/Gillian-JS/lib/Semantics/SFVL.mli @@ -23,7 +23,7 @@ val pp : Format.formatter -> t -> unit val union : t -> t -> t val lvars : t -> Containers.SS.t val alocs : t -> Containers.SS.t -val assertions : Expr.t -> t -> Asrt.t list +val assertions : Expr.t -> t -> Asrt.t val substitution : Subst.t -> bool -> t -> t val selective_substitution : Subst.t -> bool -> t -> t val is_well_formed : t -> bool diff --git a/Gillian-JS/lib/Semantics/SHeap.ml b/Gillian-JS/lib/Semantics/SHeap.ml index d0c7e1fc..34edc0fb 100644 --- a/Gillian-JS/lib/Semantics/SHeap.ml +++ b/Gillian-JS/lib/Semantics/SHeap.ml @@ -338,7 +338,7 @@ let to_list (heap : t) : (string * s_object) list = SS.fold (fun loc ac -> (loc, Option.get (get heap loc)) :: ac) domain [] (** converts a symbolic heap to a list of assertions *) -let assertions (heap : t) : Asrt.t list = +let assertions (heap : t) : Asrt.t = let make_loc_lexpr loc = if Names.is_aloc_name loc then Expr.ALoc loc else Expr.Lit (Loc loc) in @@ -359,8 +359,7 @@ let assertions (heap : t) : Asrt.t list = fv_assertions @ domain @ metadata in - List.sort Asrt.compare - (List.concat (List.map assertions_of_object (to_list heap))) + List.sort Asrt.compare (List.concat_map assertions_of_object (to_list heap)) let wf_assertions_of_obj (heap : t) (loc : string) : Formula.t list = let cfvl = diff --git a/Gillian-JS/lib/utils/asrt_utils.ml b/Gillian-JS/lib/utils/asrt_utils.ml index 4513c7f7..a90cf487 100644 --- a/Gillian-JS/lib/utils/asrt_utils.ml +++ b/Gillian-JS/lib/utils/asrt_utils.ml @@ -1,6 +1,6 @@ open JSILNames open Gillian.Gil_syntax.Asrt -let points_to ~loc ~field ~value = GA (aCell, [ loc; field ], [ value ]) -let metadata ~loc ~metadata = GA (aMetadata, [ loc ], [ metadata ]) -let empty_fields ~loc ~domain = GA (aProps, [ loc; domain ], []) +let points_to ~loc ~field ~value = CorePred (aCell, [ loc; field ], [ value ]) +let metadata ~loc ~metadata = CorePred (aMetadata, [ loc ], [ metadata ]) +let empty_fields ~loc ~domain = CorePred (aProps, [ loc; domain ], []) diff --git a/GillianCore/GIL_Syntax/Asrt.ml b/GillianCore/GIL_Syntax/Asrt.ml index 03c15815..20b755e1 100644 --- a/GillianCore/GIL_Syntax/Asrt.ml +++ b/GillianCore/GIL_Syntax/Asrt.ml @@ -167,7 +167,7 @@ let make_pure (a : t) : Formula.t = |> Formula.conjunct (** GIL logic assertions *) -let _simple_pp ?(e_pp : Format.formatter -> Expr.t -> unit = Expr.pp) fmt = +let _pp_simple ?(e_pp : Format.formatter -> Expr.t -> unit = Expr.pp) fmt = function | Emp -> Fmt.string fmt "emp" | Pred (name, params) -> @@ -191,10 +191,10 @@ let _simple_pp ?(e_pp : Format.formatter -> Expr.t -> unit = Expr.pp) fmt = let _pp ~(e_pp : Format.formatter -> Expr.t -> unit) (fmt : Format.formatter) : t -> unit = - Fmt.list ~sep:(Fmt.any " *@ ") (_simple_pp ~e_pp) fmt + Fmt.list ~sep:(Fmt.any " *@ ") (_pp_simple ~e_pp) fmt -let simple_pp = _simple_pp ~e_pp:Expr.pp -let simple_full_pp = _simple_pp ~e_pp:Expr.full_pp +let pp_simple = _pp_simple ~e_pp:Expr.pp +let pp_simple_full = _pp_simple ~e_pp:Expr.full_pp let pp = _pp ~e_pp:Expr.pp let full_pp = _pp ~e_pp:Expr.full_pp diff --git a/GillianCore/GIL_Syntax/Gil_syntax.mli b/GillianCore/GIL_Syntax/Gil_syntax.mli index 26299c32..95059e3a 100644 --- a/GillianCore/GIL_Syntax/Gil_syntax.mli +++ b/GillianCore/GIL_Syntax/Gil_syntax.mli @@ -636,9 +636,13 @@ module Asrt : sig (** Pretty-printer *) val pp : Format.formatter -> t -> unit + val pp_simple : Format.formatter -> simple -> unit + (** Full pretty-printer *) val full_pp : Format.formatter -> t -> unit + val pp_simple_full : Format.formatter -> simple -> unit + (** [star \[a1; a2; ...; an\] will return \[a1 * a2 * ... * an\]] *) val star : t list -> t diff --git a/GillianCore/GIL_Syntax/Lemma.ml b/GillianCore/GIL_Syntax/Lemma.ml index e8b64706..2db7eb03 100644 --- a/GillianCore/GIL_Syntax/Lemma.ml +++ b/GillianCore/GIL_Syntax/Lemma.ml @@ -74,7 +74,7 @@ let parameter_types (preds : (string, Pred.t) Hashtbl.t) (lemma : t) : t = with Invalid_argument _ -> Fmt.failwith "Invalid number of arguments: %a.\nInside of lemma: %s" - Asrt.simple_pp a lemma.lemma_name) + Asrt.pp_simple_full a lemma.lemma_name) in [ Types ac_types; a ] | _ -> [ a ] diff --git a/GillianCore/debugging/utils/match_map.ml b/GillianCore/debugging/utils/match_map.ml index 05a10c68..364c1957 100644 --- a/GillianCore/debugging/utils/match_map.ml +++ b/GillianCore/debugging/utils/match_map.ml @@ -63,7 +63,7 @@ functor in let assertion = let asrt, _ = asrt_report.step in - Fmt.str "%a" Asrt.pp asrt + Fmt.str "%a" Asrt.pp_simple asrt in let substitutions = asrt_report.subst |> Subst.to_list_pp diff --git a/GillianCore/engine/Abstraction/LogicPreprocessing.ml b/GillianCore/engine/Abstraction/LogicPreprocessing.ml index 19f8751b..59c6d2ad 100644 --- a/GillianCore/engine/Abstraction/LogicPreprocessing.ml +++ b/GillianCore/engine/Abstraction/LogicPreprocessing.ml @@ -12,74 +12,93 @@ let rec auto_unfold (predicates : (string, Pred.t) Hashtbl.t) (rec_tbl : (string, bool) Hashtbl.t) (asrt : Asrt.t) : Asrt.t list = - let au_rec = auto_unfold ~unfold_rec_predicates predicates rec_tbl in let au_no_rec = auto_unfold ~unfold_rec_predicates:false predicates rec_tbl in - match (asrt : Asrt.t) with - | Star (a1, a2) -> - List.filter Simplifications.admissible_assertion - (List_utils.cross_product (au_rec a1) (au_rec a2) (fun asrt1 asrt2 -> - Asrt.Star (asrt1, asrt2))) - (* We don't unfold: - - Recursive predicates (except in some very specific cases) - - predicates marked with no-unfold - - predicates with a guard *) - | Pred (name, _) - when (Hashtbl.find rec_tbl name && not unfold_rec_predicates) - || - let pred = Hashtbl.find predicates name in - pred.pred_nounfold || Option.is_some pred.pred_guard -> [ asrt ] - | Pred (name, args) when Hashtbl.mem unfolded_preds name -> - L.verbose (fun fmt -> - fmt "Unfolding predicate: %s with nounfold %b" name - (Hashtbl.find predicates name).pred_nounfold); - let pred = Hashtbl.find unfolded_preds name in - let params, _ = List.split pred.pred_params in - let combined = - try List.combine params args - with Invalid_argument _ -> - Fmt.failwith - "Impossible to auto unfold predicate %s. Used with %i args instead \ - of %i" - name (List.length args) (List.length params) - in - let subst = SVal.SSubst.init combined in - let defs = List.map (fun (_, def) -> def) pred.pred_definitions in - List.map (SVal.SSubst.substitute_asrt subst ~partial:false) defs - | Pred (name, args) -> ( - try - L.tmi (fun fmt -> fmt "AutoUnfold: %a : %s" Asrt.pp asrt name); - let pred : Pred.t = Hashtbl.find predicates name in - (* If it is not, replace the predicate assertion for the list of its definitions - substituting the formal parameters of the predicate with the corresponding - logical expressions in the argument list *) - let params, _ = List.split pred.pred_params in - let subst = SVal.SSubst.init (List.combine params args) in - Logging.tmi (fun fmt -> - fmt "PREDICATE %s has %d definitions" pred.pred_name - (List.length pred.pred_definitions)); - let new_asrts = - List.map - (fun (_, a) -> - L.tmi (fun fmt -> fmt "Before Auto Unfolding: %a" Asrt.pp a); - let facts = - List.map (fun fact -> Asrt.Pure fact) pred.pred_facts - in - let a = Asrt.star (a :: facts) in - let result = SVal.SSubst.substitute_asrt subst ~partial:false a in - L.tmi (fun fmt -> fmt "After Auto Unfolding: %a" Asrt.pp result); - result) - pred.pred_definitions - in - - (* FIXME: - If we processed the predicate definitions in order the recursive call to auto unfold - would be avoided *) - let result = List.concat (List.map au_no_rec new_asrts) in - let result = List.filter Simplifications.admissible_assertion result in - result - with Not_found -> - raise (Failure ("Error: Can't auto_unfold predicate " ^ name))) - | _ -> [ asrt ] + let options = + asrt + |> List.map (fun asrt -> + match asrt with + (* We don't unfold: + - Recursive predicates (except in some very specific cases) + - predicates marked with no-unfold + - predicates with a guard *) + | Asrt.Pred (name, _) + when (Hashtbl.find rec_tbl name && not unfold_rec_predicates) + || + let pred = Hashtbl.find predicates name in + pred.pred_nounfold || Option.is_some pred.pred_guard -> + [ [ asrt ] ] + | Pred (name, args) when Hashtbl.mem unfolded_preds name -> + L.verbose (fun fmt -> + fmt "Unfolding predicate: %s with nounfold %b" name + (Hashtbl.find predicates name).pred_nounfold); + let pred = Hashtbl.find unfolded_preds name in + let params, _ = List.split pred.pred_params in + let combined = + try List.combine params args + with Invalid_argument _ -> + Fmt.failwith + "Impossible to auto unfold predicate %s. Used with %i \ + args instead of %i" + name (List.length args) (List.length params) + in + let subst = SVal.SSubst.init combined in + let defs = + List.map (fun (_, def) -> def) pred.pred_definitions + in + List.map (SVal.SSubst.substitute_asrt subst ~partial:false) defs + | Pred (name, args) -> ( + try + L.tmi (fun fmt -> + fmt "AutoUnfold: %a : %s" Asrt.pp_simple asrt name); + let pred : Pred.t = Hashtbl.find predicates name in + (* If it is not, replace the predicate assertion for the list of its definitions + substituting the formal parameters of the predicate with the corresponding + logical expressions in the argument list *) + let params, _ = List.split pred.pred_params in + let subst = SVal.SSubst.init (List.combine params args) in + Logging.tmi (fun fmt -> + fmt "PREDICATE %s has %d definitions" pred.pred_name + (List.length pred.pred_definitions)); + let new_asrts = + List.map + (fun (_, a) -> + L.tmi (fun fmt -> + fmt "Before Auto Unfolding: %a" Asrt.pp a); + let facts = + List.map (fun fact -> Asrt.Pure fact) pred.pred_facts + in + let a = a @ facts in + let result = + SVal.SSubst.substitute_asrt subst ~partial:false a + in + L.tmi (fun fmt -> + fmt "After Auto Unfolding: %a" Asrt.pp result); + result) + pred.pred_definitions + in + + (* FIXME: + If we processed the predicate definitions in order the recursive call to auto unfold + would be avoided *) + let result = List.concat_map au_no_rec new_asrts in + List.filter Simplifications.admissible_assertion result + with Not_found -> + raise (Failure ("Error: Can't auto_unfold predicate " ^ name))) + | _ -> [ [ asrt ] ]) + in + (* Now that all assertions have been unfolded to multiple options, do a cross + product of all options to get all possible combinations of assertions + options: Asrt.t list list, ie list of options to choose from + *) + let rec cross_product (options : Asrt.t list list) : Asrt.t list = + match options with + | [] -> [] + | [ o ] -> o + | o :: os -> + let rest = cross_product os in + List.concat_map (fun a -> List.map (fun b -> a @ b) rest) o + in + cross_product options (* * Return: Hashtbl from predicate name to boolean @@ -186,7 +205,7 @@ let find_pure_preds (preds : (string, Pred.t) Hashtbl.t) : let pred = Hashtbl.find preds pred_name in let is_pure = List.for_all - (fun (_, asrt) -> Asrt.is_pure_asrt asrt) + (fun (_, asrt) -> List.for_all Asrt.is_pure_asrt asrt) pred.pred_definitions in @@ -567,8 +586,7 @@ let add_closing_tokens preds = pred with pred_definitions = List.map - (fun (x, def) -> - (x, Asrt.Star (def, Pred.close_token_call pred))) + (fun (x, def) -> (x, def @ Pred.close_token_call pred)) pred.pred_definitions; }) |> Seq.iter (fun (pred : Pred.t) -> Hashtbl.replace preds pred.pred_name pred); diff --git a/GillianCore/engine/Abstraction/MP.ml b/GillianCore/engine/Abstraction/MP.ml index 646454bb..209e2773 100644 --- a/GillianCore/engine/Abstraction/MP.ml +++ b/GillianCore/engine/Abstraction/MP.ml @@ -12,9 +12,9 @@ let outs_pp = (** The [mp_step] type represents a matching plan step, consisting of an assertion together with the possible learned outs *) -type step = Asrt.t * outs [@@deriving yojson, eq] +type step = Asrt.simple * outs [@@deriving yojson, eq] -let pp_step = Fmt.pair ~sep:(Fmt.any ", ") Asrt.pp outs_pp +let pp_step = Fmt.pair ~sep:(Fmt.any ", ") Asrt.pp_simple_full outs_pp let pp_step_list = Fmt.Dump.list pp_step type label = string * SS.t [@@deriving eq, yojson] @@ -25,7 +25,7 @@ let pp_label ft (lab, ss) = type post = Flag.t * Asrt.t list [@@deriving eq, yojson] let pp_post ft (flag, asrts) = - Fmt.pf ft "%a: %a" Flag.pp flag Asrt.pp (Asrt.star asrts) + Fmt.pf ft "%a: %a" Flag.pp flag Fmt.(list ~sep:comma Asrt.pp) asrts (** At a high level, a matching plan is a tree of assertions. *) @@ -68,11 +68,11 @@ let kb_pp = Fmt.(braces (iter ~sep:comma KB.iter Expr.full_pp)) type preds_tbl_t = (string, pred) Hashtbl.t type err = - | MPSpec of string * Asrt.t list list - | MPPred of string * Asrt.t list list - | MPLemma of string * Asrt.t list list - | MPAssert of Asrt.t * Asrt.t list list - | MPInvariant of Asrt.t * Asrt.t list list + | MPSpec of string * Asrt.t list + | MPPred of string * Asrt.t list + | MPLemma of string * Asrt.t list + | MPAssert of Asrt.t * Asrt.t list + | MPInvariant of Asrt.t * Asrt.t list [@@deriving show] exception MPError of err @@ -499,15 +499,15 @@ let ins_outs_formula (kb : KB.t) (pf : Formula.t) : (KB.t * outs) list = let ins_outs_assertion (pred_ins : (string, int list) Hashtbl.t) (kb : KB.t) - (asrt : Asrt.t) : (KB.t * outs) list = + (asrt : Asrt.simple) : (KB.t * outs) list = let get_pred_ins name = match Hashtbl.find_opt pred_ins name with | None -> raise (Failure ("ins_outs_assertion. Unknown Predicate: " ^ name)) | Some ins -> ins in - match (asrt : Asrt.t) with + match (asrt : Asrt.simple) with | Pure form -> ins_outs_formula kb form - | GA (_, lie, loe) -> ins_and_outs_from_lists kb lie loe + | CorePred (_, lie, loe) -> ins_and_outs_from_lists kb lie loe | Pred (p_name, args) -> let p_ins = get_pred_ins p_name in let _, lie, loe = @@ -536,19 +536,18 @@ let ins_outs_assertion raise (Failure "Impossible: non-simple assertion in ins_outs_assertion.") let collect_simple_asrts a = - let rec aux (a : Asrt.t) : Asrt.t Seq.t = + let rec aux (a : Asrt.simple) : Asrt.simple list = match a with - | Pure True | Emp -> Seq.empty - | Pure (And (f1, f2)) -> Seq.append (aux (Pure f1)) (aux (Pure f2)) - | Pure _ | Pred _ | GA _ | Wand _ -> Seq.return a + | Pure True | Emp -> [] + | Pure (And (f1, f2)) -> aux (Pure f1) @ aux (Pure f2) + | Pure _ | Pred _ | CorePred _ | Wand _ -> [ a ] | Types _ -> ( - let a = Reduction.reduce_assertion a in + let a = Reduction.reduce_assertion [ a ] in match a with - | Types les -> Seq.map (fun e -> Asrt.Types [ e ]) (List.to_seq les) - | _ -> aux a) - | Star (a1, a2) -> Seq.append (aux a1) (aux a2) + | [ Types les ] -> List.map (fun e -> Asrt.Types [ e ]) les + | _ -> List.concat_map aux a) in - List.of_seq (aux a) + List.concat_map aux a let collect_and_simplify_atoms a = let atoms = collect_simple_asrts a in @@ -558,7 +557,7 @@ let collect_and_simplify_atoms a = let separating, overlapping = List.partition (function - | Asrt.Pred _ | Asrt.GA _ | Asrt.Wand _ -> true + | Asrt.Pred _ | Asrt.CorePred _ | Asrt.Wand _ -> true | _ -> false) atoms in @@ -575,7 +574,7 @@ let s_init_atoms ~preds kb atoms = L.verbose (fun m -> m "KNOWN: @[%a@].@\n@[CUR MP:@\n%a@]@\nTO VISIT: @[%a@]" kb_pp kb pp_step_list current - (Fmt.list ~sep:(Fmt.any "@\n") Asrt.full_pp) + (Fmt.list ~sep:(Fmt.any "@\n") Asrt.pp_simple_full) rest); match rest with | [] -> @@ -595,7 +594,7 @@ let s_init_atoms ~preds kb atoms = search [] kb atoms let s_init ~(preds : (string, int list) Hashtbl.t) (kb : KB.t) (a : Asrt.t) : - (step list, Asrt.t list) result = + (step list, Asrt.t) result = L.verbose (fun m -> m "Entering s-init on: %a\n\nKB: %a\n" Asrt.pp a kb_pp kb); let atoms = collect_and_simplify_atoms a in s_init_atoms ~preds kb atoms @@ -659,7 +658,7 @@ let init (preds : (string, int list) Hashtbl.t) (asrts_posts : (Asrt.t * ((string * SS.t) option * (Flag.t * Asrt.t list) option)) list) - : (t, Asrt.t list list) result = + : (t, Asrt.simple list list) result = let known_matchables = match use_params with | None -> known_matchables @@ -908,32 +907,32 @@ let get_lemma (prog : 'a prog) (name : string) : (lemma, unit) result = | Some lemma -> Ok lemma | None -> Error () -let rec pp_asrt +let pp_asrt ?(preds_printer : (Format.formatter -> string * Expr.t list -> unit) option) ~(preds : preds_tbl_t) (fmt : Format.formatter) (a : Asrt.t) = - let pp_asrt = pp_asrt ?preds_printer ~preds in - match a with - | Star (a1, a2) -> Fmt.pf fmt "%a *@ %a" pp_asrt a1 pp_asrt a2 - | Pred (name, args) -> ( - match preds_printer with - | Some pp_pred -> (Fmt.hbox pp_pred) fmt (name, args) - | None -> ( - try - let pred = get_pred_def preds name in - let out_params = Pred.out_params pred.pred in - let out_args = Pred.out_args pred.pred args in - let in_args = Pred.in_args pred.pred args in - let out_params_args = List.combine out_params out_args in - let pp_out_params_args fmt (x, e) = - Fmt.pf fmt "@[%s: %a@]" x Expr.pp e - in - Fmt.pf fmt "%s(@[%a@])" name - (Pred.pp_ins_outs pred.pred Expr.pp pp_out_params_args) - (in_args, out_params_args) - with _ -> Asrt.pp fmt a)) - | a -> Asrt.pp fmt a + let pp_simple_asrt fmt = function + | Asrt.Pred (name, args) -> ( + match preds_printer with + | Some pp_pred -> (Fmt.hbox pp_pred) fmt (name, args) + | None -> ( + try + let pred = get_pred_def preds name in + let out_params = Pred.out_params pred.pred in + let out_args = Pred.out_args pred.pred args in + let in_args = Pred.in_args pred.pred args in + let out_params_args = List.combine out_params out_args in + let pp_out_params_args fmt (x, e) = + Fmt.pf fmt "@[%s: %a@]" x Expr.pp e + in + Fmt.pf fmt "%s(@[%a@])" name + (Pred.pp_ins_outs pred.pred Expr.pp pp_out_params_args) + (in_args, out_params_args) + with _ -> Asrt.pp fmt a)) + | a -> Asrt.pp_simple_full fmt a + in + Fmt.list ~sep:(Fmt.any " *@ ") pp_simple_asrt fmt a let pp_sspec ?(preds_printer : (Format.formatter -> string * Expr.t list -> unit) option) diff --git a/GillianCore/engine/Abstraction/MP.mli b/GillianCore/engine/Abstraction/MP.mli index 63a85792..dc45ccd5 100644 --- a/GillianCore/engine/Abstraction/MP.mli +++ b/GillianCore/engine/Abstraction/MP.mli @@ -7,7 +7,7 @@ val outs_pp : outs Fmt.t (** The [step] type represents a matching plan step, consisting of an assertion together with the possible learned outs *) -type step = Asrt.t * outs [@@deriving yojson] +type step = Asrt.simple * outs [@@deriving yojson] type label = string * SS.t [@@deriving yojson] type post = Flag.t * Asrt.t list [@@deriving yojson] @@ -40,11 +40,11 @@ type 'annot prog = { type preds_tbl_t = (string, pred) Hashtbl.t type err = - | MPSpec of string * Asrt.t list list - | MPPred of string * Asrt.t list list - | MPLemma of string * Asrt.t list list - | MPAssert of Asrt.t * Asrt.t list list - | MPInvariant of Asrt.t * Asrt.t list list + | MPSpec of string * Asrt.t list + | MPPred of string * Asrt.t list + | MPLemma of string * Asrt.t list + | MPAssert of Asrt.t * Asrt.t list + | MPInvariant of Asrt.t * Asrt.t list [@@deriving show] module KB = Expr.Set @@ -53,13 +53,13 @@ val learn_expr : ?top_level:bool -> KB.t -> Gil_syntax.Expr.t -> Gil_syntax.Expr.t -> outs val ins_outs_expr : KB.t -> Expr.t -> Expr.t -> (KB.t * outs) list -val collect_simple_asrts : Asrt.t -> Asrt.t list +val collect_simple_asrts : Asrt.t -> Asrt.simple list val s_init_atoms : preds:(string, int list) Hashtbl.t -> KB.t -> - Asrt.t list -> - (step list, Asrt.t list) result + Asrt.t -> + (step list, Asrt.t) result val of_step_list : ?post:post -> ?label:label -> step list -> t @@ -69,7 +69,7 @@ val init : KB.t -> (string, int list) Hashtbl.t -> (Asrt.t * ((string * SS.t) option * (Flag.t * Asrt.t list) option)) list -> - (t, Asrt.t list list) result + (t, Asrt.t list) result val init_prog : ?preds_tbl:(string, pred) Hashtbl.t -> diff --git a/GillianCore/engine/Abstraction/Matcher.ml b/GillianCore/engine/Abstraction/Matcher.ml index 17d6edec..1e7050ec 100644 --- a/GillianCore/engine/Abstraction/Matcher.ml +++ b/GillianCore/engine/Abstraction/Matcher.ml @@ -76,7 +76,9 @@ module type S = sig type unfold_info_t = (string * string) list - val produce_assertion : t -> SVal.SESubst.t -> Asrt.t -> (t, err_t) Res_list.t + val produce_assertion : + t -> SVal.SESubst.t -> Asrt.simple -> (t, err_t) Res_list.t + val produce : t -> SVal.SESubst.t -> Asrt.t -> (t, err_t) Res_list.t val produce_posts : t -> SVal.SESubst.t -> Asrt.t list -> t list @@ -568,8 +570,10 @@ module Make (State : SState.S) : in Some (actual_pred, args) - let rec produce_assertion (astate : t) (subst : SVal.SESubst.t) (a : Asrt.t) : - (t, err_t) Res_list.t = + let rec produce_assertion + (astate : t) + (subst : SVal.SESubst.t) + (a : Asrt.simple) : (t, err_t) Res_list.t = let open Res_list.Syntax in let { state; preds; pred_defs; variants; wands } = astate in let other_state_err msg = [ Error (StateErr.EOther msg) ] in @@ -580,12 +584,12 @@ module Make (State : SState.S) : Produce simple assertion: @[%a@]@\n\ With subst: %a\n\ \ -------------------------@\n" - Asrt.pp a SVal.SESubst.pp subst); + Asrt.pp_simple a SVal.SESubst.pp subst); L.verbose (fun m -> m "STATE: %a" pp_astate astate); - match a with - | GA (a_id, ins, outs) -> + match (a : Asrt.simple) with + | CorePred (a_id, ins, outs) -> L.verbose (fun fmt -> fmt "Memory producer."); let vs = List.map (subst_in_expr subst) (ins @ outs) in @@ -714,10 +718,8 @@ module Make (State : SState.S) : { state = state'; preds; wands; pred_defs; variants }) | _ -> L.fail "Produce simple assertion: unsupported assertion" - and produce_asrt_list - (astate : t) - (subst : SVal.SESubst.t) - (sas : Asrt.t list) : (t, err_t) Res_list.t = + and produce_asrt_list (astate : t) (subst : SVal.SESubst.t) (sas : Asrt.t) : + (t, err_t) Res_list.t = let open Res_list.Syntax in let other_state_err msg = Res_list.error_with (StateErr.EOther msg) in let () = @@ -1214,7 +1216,7 @@ module Make (State : SState.S) : (let a = fst step in (* Get pvars, lvars, locs from the assertion *) let a_pvars, a_lvars, a_locs = - (Asrt.pvars a, Asrt.lvars a, Asrt.locs a) + (Asrt.pvars [ a ], Asrt.lvars [ a ], Asrt.locs [ a ]) in let filter_vars = SS.union a_pvars (SS.union a_lvars a_locs) in @@ -1269,12 +1271,12 @@ module Make (State : SState.S) : L.Logging_constants.Content_type.assertion (fun () -> let p, outs = step in let open Res_list.Syntax in - match (p : Asrt.t) with - | GA (a_id, e_ins, e_outs) -> ( + match (p : Asrt.simple) with + | CorePred (a_id, e_ins, e_outs) -> ( let vs_ins = List.map (subst_in_expr_opt astate subst) e_ins in let failure = List.exists (fun x -> x = None) vs_ins in if failure then ( - Fmt.pr "I don't know all ins for %a????" Asrt.pp p; + Fmt.pr "I don't know all ins for %a????" Asrt.pp_simple p; if !Config.under_approximation then [] else resource_fail) else let vs_ins = List.map Option.get vs_ins in @@ -1437,7 +1439,7 @@ module Make (State : SState.S) : StateErr.EAsrt (les, Not conjunct, [ [ Pure conjunct ] ]) in Res_list.error_with error) - (* LTrue, LFalse, LEmp, LStar *) + (* LTrue, LFalse, LEmp *) | _ -> raise (Failure "Illegal Assertion in Matching Plan")) and match_assertion_safely ?(no_auto_fold = false) state subst step = @@ -1463,7 +1465,7 @@ module Make (State : SState.S) : let other_error = StateErr.EOther (Fmt.str "Uncaught exception while matching assertions %a" - Asrt.pp (fst step)) + Asrt.pp_simple (fst step)) in Res_list.error_with other_error) @@ -1862,7 +1864,7 @@ module Make (State : SState.S) : let get_defs (pred : Pred.t) largs = if pred.pred_abstract || Option.is_some pred.pred_guard then - [ Asrt.Pred (pred.pred_name, largs) ] + [ [ Asrt.Pred (pred.pred_name, largs) ] ] else let unfolded_pred = Hashtbl.find_opt LogicPreprocessing.unfolded_preds pred.pred_name @@ -1970,7 +1972,7 @@ module Make (State : SState.S) : init_subst; fold_outs_info = (subst, step, out_params, out_args); } - | (GA (core_pred, ins, outs), _), [ err ] -> + | (CorePred (core_pred, ins, outs), _), [ err ] -> (* What we do here is simulate the idea that the core predicate is actually a folded core-predicate *) let kb = List.to_seq ins @@ -2017,7 +2019,7 @@ module Make (State : SState.S) : List.init out_amount (fun o_i -> all_new_outs.((cp_i * out_amount) + o_i)) in - Asrt.GA (core_pred, ins, outs)) + Asrt.CorePred (core_pred, ins, outs)) new_ins_l in let learning_equalities = @@ -2091,11 +2093,12 @@ module Make (State : SState.S) : ]) (Ok state) obtained expected - let rec package_case_step { lhs_state; current_state; subst } step : - (package_state list, err_t list) Result.t = + let rec package_case_step + { lhs_state; current_state; subst } + (step : MP.step) : (package_state list, err_t list) Result.t = let open Syntaxes.Result in L.verbose (fun m -> - m "Wand about to consume RHS step: %a" Asrt.pp (fst step)); + m "Wand about to consume RHS step: %a" Asrt.pp_simple (fst step)); (* States are modified in place unfortunately.. so we have to copy them just in case *) (* First we try to consume from the lhs_state *) let- lhs_errs = diff --git a/GillianCore/engine/Abstraction/Matcher.mli b/GillianCore/engine/Abstraction/Matcher.mli index c9f3e8bb..d82ae684 100644 --- a/GillianCore/engine/Abstraction/Matcher.mli +++ b/GillianCore/engine/Abstraction/Matcher.mli @@ -76,11 +76,13 @@ module type S = sig type unfold_info_t = (string * string) list - val produce_assertion : t -> SVal.SESubst.t -> Asrt.t -> (t, err_t) Res_list.t + val produce_assertion : + t -> SVal.SESubst.t -> Asrt.simple -> (t, err_t) Res_list.t + val produce : t -> SVal.SESubst.t -> Asrt.t -> (t, err_t) Res_list.t val produce_posts : t -> SVal.SESubst.t -> Asrt.t list -> t list - (** [unfold state name args unfold_info] returns a + (** [unfold state name args unfold_info] returns a list of pairs (subst, state), resulting from unfolding the predicate [name(..args..)] from the given state. unfold_info contains information about how to bind new variables. *) diff --git a/GillianCore/engine/Abstraction/Normaliser.ml b/GillianCore/engine/Abstraction/Normaliser.ml index 67686cc2..46a64d99 100644 --- a/GillianCore/engine/Abstraction/Normaliser.ml +++ b/GillianCore/engine/Abstraction/Normaliser.ml @@ -20,7 +20,7 @@ module Make (SPState : PState.S) = struct (* 1 - Find the lists for which we know the length *) let find_list_exprs_to_concretize (a : Asrt.t) : (Expr.t, Expr.t list) Hashtbl.t = - let rec collect_concretizable_lists = function + let collect_concretizable_lists = function | Asrt.Pure (Eq (EList _, EList _)) -> [] | Pure (Eq (le, EList les)) | Pure (Eq (EList les, le)) -> [ (le, les) ] | Pure (Eq (UnOp (LstLen, le), Lit (Int i))) @@ -29,13 +29,9 @@ module Make (SPState : PState.S) = struct List.init (Z.to_int i) (fun _ -> Expr.LVar (LVar.alloc ())) in [ (le, les) ] - | Star (a1, a2) -> - List.rev_append - (collect_concretizable_lists a1) - (collect_concretizable_lists a2) | _ -> [] in - let lst_exprs = collect_concretizable_lists a in + let lst_exprs = List.concat_map collect_concretizable_lists a in let lists_tbl = Hashtbl.create 1 in List.iter (fun (le, les) -> @@ -77,12 +73,9 @@ module Make (SPState : PState.S) = struct let make_new_list_as (a : Asrt.t) (new_lists : (Expr.t, Expr.t list) Hashtbl.t) : Asrt.t = - let new_list_as = - Hashtbl.fold - (fun le les (ac : Asrt.t list) -> Pure (Eq (le, EList les)) :: ac) - new_lists [ a ] - in - Asrt.star new_list_as + Hashtbl.fold + (fun le les (ac : Asrt.t) -> Pure (Eq (le, EList les)) :: ac) + new_lists a in (* Doing IT *) @@ -561,29 +554,25 @@ module Make (SPState : PState.S) = struct result (** Separate an assertion into: core_asrts, pure, typing and predicates *) - let rec separate_assertion (a : Asrt.t) : + let separate_assertion (a : Asrt.t) : (string * Expr.t list * Expr.t list) list * Formula.t list * (Expr.t * Type.t) list * (string * Expr.t list) list * Wands.wand list = - let f = separate_assertion in - - match a with - | Star (al, ar) -> - let core_asrts_l, pure_l, types_l, preds_l, wands_l = f al in - let core_asrts_r, pure_r, types_r, preds_r, wands_r = f ar in - ( core_asrts_l @ core_asrts_r, - pure_l @ pure_r, - types_l @ types_r, - preds_l @ preds_r, - wands_l @ wands_r ) - | GA (a, es1, es2) -> ([ (a, es1, es2) ], [], [], [], []) - | Wand { lhs; rhs } -> ([], [], [], [], [ { lhs; rhs } ]) - | Emp -> ([], [], [], [], []) - | Types lst -> ([], [], lst, [], []) - | Pred (name, params) -> ([], [], [], [ (name, params) ], []) - | Pure f -> ([], [ f ], [], [], []) + List.fold_left + (fun (core_asrts, pure, types, preds, wands) (a : Asrt.simple) -> + match a with + | CorePred (a, es1, es2) -> + ((a, es1, es2) :: core_asrts, pure, types, preds, wands) + | Wand { lhs; rhs } -> + (core_asrts, pure, types, preds, Wands.{ lhs; rhs } :: wands) + | Emp -> (core_asrts, pure, types, preds, wands) + | Types lst -> (core_asrts, pure, lst @ types, preds, wands) + | Pred (name, params) -> + (core_asrts, pure, types, (name, params) :: preds, wands) + | Pure f -> (core_asrts, f :: pure, types, preds, wands)) + ([], [], [], [], []) a (** Normalise type assertions (Intialise type environment *) let normalise_types @@ -844,7 +833,7 @@ module Make (SPState : PState.S) = struct (fun current_states (a, ins, outs) -> let open Syntaxes.List in let* current_state = current_states in - SPState.produce current_state subst (Asrt.GA (a, ins, outs)) + SPState.produce current_state subst [ Asrt.CorePred (a, ins, outs) ] |> (* If some production fails, we ignore *) List.filter_map (function | Ok x -> Some x @@ -852,8 +841,9 @@ module Make (SPState : PState.S) = struct L.verbose (fun m -> m "One branch of produce GA failed for: %a!\n\ - with Message: %a. Might have lost some paths ?" Asrt.pp - (Asrt.GA (a, ins, outs)) + with Message: %a. Might have lost some paths ?" + Asrt.pp_simple + (Asrt.CorePred (a, ins, outs)) SPState.pp_err msg); None)) [ astate ] @@ -883,12 +873,8 @@ module Make (SPState : PState.S) = struct let a = Reduction.reduce_assertion a in let subst = SESubst.init [] in - let rec find_spec_var_eqs (a : Asrt.t) = - let f = find_spec_var_eqs in + let find_spec_var_eqs (a : Asrt.simple) = match a with - | Star (al, ar) -> - f al; - f ar | Pure (Eq (LVar x, LVar y)) when is_spec_var_name x && not (is_spec_var_name y) -> SESubst.put subst (LVar y) (LVar x) @@ -897,7 +883,7 @@ module Make (SPState : PState.S) = struct SESubst.put subst (LVar x) (LVar y) | _ -> () in - find_spec_var_eqs a; + List.iter find_spec_var_eqs a; SESubst.substitute_asrt subst ~partial:true a (** Given an assertion creates a symbolic state and a substitution *) diff --git a/GillianCore/engine/Abstraction/PState.ml b/GillianCore/engine/Abstraction/PState.ml index 200377d4..6a7dd8d7 100644 --- a/GillianCore/engine/Abstraction/PState.ml +++ b/GillianCore/engine/Abstraction/PState.ml @@ -262,7 +262,7 @@ module Make (State : SState.S) : |> SS.union (Preds.get_lvars preds) |> SS.union (Wands.get_lvars wands) - let to_assertions ?(to_keep : SS.t option) (astate : t) : Asrt.t list = + let to_assertions ?(to_keep : SS.t option) (astate : t) : Asrt.t = let { state; preds; wands; _ } = astate in let s_asrts = State.to_assertions ?to_keep state in let p_asrts = Preds.to_assertions preds in @@ -410,7 +410,7 @@ module Make (State : SState.S) : preds_list; { state; preds; wands = Wands.init []; pred_defs; variants } - let consume ~(prog : 'a MP.prog) astate a binders = + let consume ~(prog : 'a MP.prog) astate (a : Asrt.t) binders = if not (List.for_all Names.is_lvar_name binders) then failwith "Binding of pure variables in *-assert."; let store = State.get_store astate.state in @@ -505,9 +505,8 @@ module Make (State : SState.S) : let new_bindings = List.map (fun (e, e_v) -> Asrt.Pure (Eq (e, e_v))) new_bindings in - let a_new_bindings = Asrt.star new_bindings in let full_subst = make_id_subst a in - let a_produce = a_new_bindings in + let a_produce = new_bindings in let open Res_list.Syntax in let result = let** new_astate = SMatcher.produce new_state full_subst a_produce in @@ -723,8 +722,7 @@ module Make (State : SState.S) : | _ -> true) |> List.map (fun (e, e_v) -> Asrt.Pure (Eq (e, e_v))) in - let a_bindings = Asrt.star bindings in - let subst_bindings = make_id_subst a_bindings in + let subst_bindings = make_id_subst bindings in let pvar_subst_list_known = List.map (fun x -> @@ -749,7 +747,7 @@ module Make (State : SState.S) : in L.verbose (fun fmt -> fmt "Invariant v2: %a" Asrt.pp a_substed); let a_produce = - Reduction.reduce_assertion (Asrt.star [ a_bindings; a_substed ]) + Reduction.reduce_assertion (Asrt.star [ bindings; a_substed ]) in L.verbose (fun fmt -> fmt "Invariant v3: %a" Asrt.pp a_produce); (* Create empty state *) @@ -803,7 +801,7 @@ module Make (State : SState.S) : (fun astates (id, frame) -> let** astate = astates in let** astate = - let frame_asrt = Asrt.star (to_assertions frame) in + let frame_asrt = to_assertions frame in let full_subst = make_id_subst frame_asrt in let+ produced = SMatcher.produce astate full_subst frame_asrt in match produced with @@ -1013,7 +1011,7 @@ module Make (State : SState.S) : let new_bindings = List.map (fun (e, e_v) -> Asrt.Pure (Eq (e, e_v))) new_bindings in - let a_new_bindings = Asrt.star new_bindings in + let a_new_bindings = new_bindings in let subst_bindings = make_id_subst a_new_bindings in let full_subst = make_id_subst a in let _ = SVal.SESubst.merge_left full_subst subst_bindings in diff --git a/GillianCore/engine/Abstraction/Preds.ml b/GillianCore/engine/Abstraction/Preds.ml index 5b950f88..46d6d950 100644 --- a/GillianCore/engine/Abstraction/Preds.ml +++ b/GillianCore/engine/Abstraction/Preds.ml @@ -223,7 +223,7 @@ let substitution_in_place (subst : st) (preds : t) : unit = let pred_substitution subst (s, vs) = (s, List.map (subst_in_val subst) vs) in preds := List.map (pred_substitution subst) !preds -let to_assertions (preds : t) : Asrt.t list = +let to_assertions (preds : t) : Asrt.simple list = let preds = to_list preds in let pred_to_assert (n, args) = Asrt.Pred (n, args) in List.sort Asrt.compare (List.map pred_to_assert preds) diff --git a/GillianCore/engine/Abstraction/Preds.mli b/GillianCore/engine/Abstraction/Preds.mli index 89c35fde..ad1e0011 100644 --- a/GillianCore/engine/Abstraction/Preds.mli +++ b/GillianCore/engine/Abstraction/Preds.mli @@ -40,4 +40,4 @@ val get_all : maintain:bool -> (abs_t -> bool) -> t -> abs_t list val substitution_in_place : SVal.SESubst.t -> t -> unit (** Turns a predicate set into a list of assertions *) -val to_assertions : t -> Asrt.t list +val to_assertions : t -> Asrt.t diff --git a/GillianCore/engine/Abstraction/Verifier.ml b/GillianCore/engine/Abstraction/Verifier.ml index 0f2a1114..cb8cb7a8 100644 --- a/GillianCore/engine/Abstraction/Verifier.ml +++ b/GillianCore/engine/Abstraction/Verifier.ml @@ -189,7 +189,7 @@ struct posts in if not to_verify then - let pre' = Asrt.star (SPState.to_assertions ss_pre) in + let pre' = SPState.to_assertions ss_pre in (None, Some (pre', posts)) else (* Step 4 - create a matching plan for the postconditions and s_test *) @@ -229,7 +229,7 @@ struct L.verbose (fun m -> m "%s" msg); (None, None) | Ok post_mp -> - let pre' = Asrt.star (SPState.to_assertions ss_pre) in + let pre' = SPState.to_assertions ss_pre in let ss_pre = match flag with (* Lemmas should not have stores when being proven *) diff --git a/GillianCore/engine/BiAbduction/Abductor.ml b/GillianCore/engine/BiAbduction/Abductor.ml index 28a153ce..75add5ab 100644 --- a/GillianCore/engine/BiAbduction/Abductor.ml +++ b/GillianCore/engine/BiAbduction/Abductor.ml @@ -90,13 +90,12 @@ module Make SPState.simplify ~kill_new_lvars:true state_f in let+ final_simplified = finals_simplified in - Asrt.star - (List.sort Asrt.compare - (SPState.to_assertions ~to_keep:pvars final_simplified)) + List.sort Asrt.compare + (SPState.to_assertions ~to_keep:pvars final_simplified) in let+ pre = - let af_asrt = Asrt.star (SPState.to_assertions state_af) in + let af_asrt = SPState.to_assertions state_af in let af_subst = make_id_subst af_asrt in let* af_produce_res = SPState.produce state_i af_subst af_asrt in match af_produce_res with @@ -105,9 +104,8 @@ module Make SPState.simplify ~kill_new_lvars:true state_i' in let+ simplified = simplifieds in - Asrt.star - (List.sort Asrt.compare - (SPState.to_assertions ~to_keep:pvars simplified)) + List.sort Asrt.compare + (SPState.to_assertions ~to_keep:pvars simplified) | Error _ -> L.verbose (fun m -> m "Failed to produce anti-frame"); [] diff --git a/GillianCore/engine/BiAbduction/BiState.ml b/GillianCore/engine/BiAbduction/BiState.ml index 056bb9cd..03345f20 100644 --- a/GillianCore/engine/BiAbduction/BiState.ml +++ b/GillianCore/engine/BiAbduction/BiState.ml @@ -149,7 +149,7 @@ module Make (State : SState.S) = struct let get_spec_vars ({ state; _ } : t) : Var.Set.t = State.get_spec_vars state let get_lvars ({ state; _ } : t) : Var.Set.t = State.get_lvars state - let to_assertions ?(to_keep : SS.t option) ({ state; _ } : t) : Asrt.t list = + let to_assertions ?(to_keep : SS.t option) ({ state; _ } : t) : Asrt.t = State.to_assertions ?to_keep state let evaluate_slcmd (prog : 'a MP.prog) (lcmd : SLCmd.t) (bi_state : t) : @@ -213,9 +213,8 @@ module Make (State : SState.S) = struct | Some s -> State.assume_t s e t) (Some this_state) |> Option.to_list - | GA (corepred, ins, outs) -> + | CorePred (corepred, ins, outs) -> State.produce_core_pred corepred this_state (ins @ outs) - | Star _ -> raise (Failure "DEATH. fix_list_apply star") | Wand _ -> raise (Failure "DEATH. fix_list_apply wand") | Pred _ -> raise (Failure "DEATH. fix_list_apply pred")) [ s ] @@ -258,7 +257,8 @@ module Make (State : SState.S) = struct "@[WARNING: Match Assertion Failed: %a with error: \ %a. CUR SUBST:@\n\ %a@]@\n" - Asrt.pp (fst step) State.pp_err err SVal.SESubst.pp subst); + Asrt.pp_simple (fst step) State.pp_err err SVal.SESubst.pp + subst); if not (State.can_fix err) then ( L.verbose (fun m -> m "CANNOT FIX!"); []) @@ -448,7 +448,7 @@ module Make (State : SState.S) = struct (* to throw errors: *) - let get_fixes (_ : err_t) : Asrt.t list list = + let get_fixes (_ : err_t) : Asrt.t list = raise (Failure "get_fixes not implemented in MakeBiState") let get_recovery_tactic (_ : t) (_ : err_t list) = diff --git a/GillianCore/engine/FOLogic/Reduction.ml b/GillianCore/engine/FOLogic/Reduction.ml index 31a205c0..ddbbd758 100644 --- a/GillianCore/engine/FOLogic/Reduction.ml +++ b/GillianCore/engine/FOLogic/Reduction.ml @@ -2159,7 +2159,7 @@ and simplify_int_arithmetic_lexpr | _ -> le (** Checks if an int expression is greater than zero. - + @returns [Some true] if definitely > 0, [Some false] if definitely < 0, and [None] if both outcomes are satisfiable. *) and check_ge_zero_int ?(top_level = false) (pfs : PFS.t) (e : Expr.t) : @@ -3172,59 +3172,53 @@ end module ETSet = Set.Make (MyET) let reduce_types (a : Asrt.t) : Asrt.t = - let rec separate (a : Asrt.t) = - match a with - | Pure True -> ([], []) - | Pure False -> raise PFSFalse - | Pure (Eq (UnOp (TypeOf, e), Lit (Type t))) - | Pure (Eq (Lit (Type t), UnOp (TypeOf, e))) -> ([], [ (e, t) ]) - | Star (a1, a2) -> - let fa1, ft1 = separate a1 in - let fa2, ft2 = separate a2 in - (fa1 @ fa2, ft1 @ ft2) - | Types ets -> ([], ets) - | _ -> ([ a ], []) - in - try - let others, ets = separate a in + let others, ets = + List.fold_left + (fun (others, ets) -> function + | Asrt.Pure True -> (others, ets) + | Asrt.Pure False -> raise PFSFalse + | Asrt.Pure (Eq (UnOp (TypeOf, e), Lit (Type t))) + | Asrt.Pure (Eq (Lit (Type t), UnOp (TypeOf, e))) -> + (others, (e, t) :: ets) + | Asrt.Types ets' -> (others, ets' @ ets) + | a -> (a :: others, ets)) + ([], []) a + in let ets = ETSet.elements (ETSet.of_list ets) in match (others, ets) with - | [], [] -> Pure True - | [], ets -> Types ets - | a, ets -> - let result = Asrt.star a in - if ets = [] then result else Star (Types ets, result) - with PFSFalse -> Pure False + | [], [] -> [ Asrt.Pure True ] (* Could this be []? *) + | [], ets -> [ Asrt.Types ets ] + | others, [] -> others + | others, ets -> Asrt.Types ets :: others + with PFSFalse -> [ Asrt.Pure False ] (* Reduction of assertions *) -let rec reduce_assertion_loop +let reduce_assertion_loop (matching : bool) (pfs : PFS.t) (gamma : Type_env.t) (a : Asrt.t) : Asrt.t = - let f = reduce_assertion_loop matching pfs gamma in let fe = reduce_lexpr_loop ~matching pfs gamma in - let result = - match a with + let f : Asrt.simple -> Asrt.t = function (* Empty heap *) - | Emp -> Asrt.Emp + | Asrt.Emp -> [] (* Star *) - | Star (a1, a2) -> ( - match (f a1, f a2) with - | Emp, a | a, Emp -> a - | Pure False, _ | _, Pure False -> Asrt.Pure False - | Pure True, a | a, Pure True -> a - | fa1, fa2 -> Star (fa1, fa2)) | Wand { lhs = lname, largs; rhs = rname, rargs } -> - Wand - { lhs = (lname, List.map fe largs); rhs = (rname, List.map fe rargs) } + [ + Wand + { + lhs = (lname, List.map fe largs); + rhs = (rname, List.map fe rargs); + }; + ] (* Predicates *) - | Pred (name, les) -> Pred (name, List.map fe les) + | Pred (name, les) -> [ Pred (name, List.map fe les) ] (* Pure assertions *) - | Pure True -> Emp - | Pure f -> Pure (reduce_formula_loop ~top_level:true matching pfs gamma f) + | Pure True -> [] + | Pure f -> + [ Pure (reduce_formula_loop ~top_level:true matching pfs gamma f) ] (* Types *) | Types lvt -> ( try @@ -3237,24 +3231,27 @@ let rec reduce_assertion_loop | _ -> (e, t) :: ac) lvt [] in - if lvt = [] then Emp else Types lvt - with WrongType -> Pure False) + if lvt = [] then [] else [ Types lvt ] + with WrongType -> [ Pure False ]) (* General action *) - | GA (act, l_ins, l_outs) -> GA (act, List.map fe l_ins, List.map fe l_outs) + | CorePred (act, l_ins, l_outs) -> + [ CorePred (act, List.map fe l_ins, List.map fe l_outs) ] + in + let result = List.concat_map f a in + let result = + if List.mem (Asrt.Pure False) result then [ Asrt.Pure False ] else result in - if a <> result && not (a == result) then ( - L.(tmi (fun m -> m "Reduce_assertion: %a -> %a" Asrt.pp a Asrt.pp result)); - f result) - else result + (if a <> result && not (a == result) then + L.(tmi (fun m -> m "Reduce_assertion: %a -> %a" Asrt.pp a Asrt.pp result))); + result -let rec extract_lvar_equalities (a : Asrt.t) = - match a with - | Pure (Eq (LVar x, v) | Eq (v, LVar x)) -> - if Names.is_lvar_name x && not (Names.is_spec_var_name x) then [ (x, v) ] - else [] - | Star (a1, a2) -> extract_lvar_equalities a1 @ extract_lvar_equalities a2 - | _ -> [] +let extract_lvar_equalities : Asrt.t -> (string * Expr.t) list = + List.filter_map @@ function + | Asrt.Pure (Eq (LVar x, v) | Eq (v, LVar x)) -> + if Names.is_lvar_name x && not (Names.is_spec_var_name x) then Some (x, v) + else None + | _ -> None let reduce_assertion ?(matching = false) diff --git a/GillianCore/engine/FOLogic/Simplifications.ml b/GillianCore/engine/FOLogic/Simplifications.ml index 3603cfec..b3d4c62a 100644 --- a/GillianCore/engine/FOLogic/Simplifications.ml +++ b/GillianCore/engine/FOLogic/Simplifications.ml @@ -997,11 +997,7 @@ let admissible_assertion (a : Asrt.t) : bool = let a = Asrt.pvars_to_lvars a in - let rec separate (a : Asrt.t) = - match a with - | Star (a1, a2) -> - separate a1; - separate a2 + let separate : Asrt.simple -> unit = function | Pure f -> PFS.extend pfs f | Types ets -> List.iter @@ -1013,7 +1009,7 @@ let admissible_assertion (a : Asrt.t) : bool = | _ -> () in try - separate a; + List.iter separate a; let _ = simplify_pfs_and_gamma ~kill_new_lvars:true pfs gamma in let res = not (PFS.mem pfs Formula.False) in if res then L.tmi (fun m -> m "Admissible !!") diff --git a/GillianCore/engine/concrete_semantics/CState.ml b/GillianCore/engine/concrete_semantics/CState.ml index 71bb9c00..03a60e7b 100644 --- a/GillianCore/engine/concrete_semantics/CState.ml +++ b/GillianCore/engine/concrete_semantics/CState.ml @@ -141,7 +141,7 @@ end = struct let get_lvars _ = raise (Failure "ERROR: get_lvars called for concrete executions") - let to_assertions ?to_keep:_ (_ : t) : Asrt.t list = + let to_assertions ?to_keep:_ (_ : t) : Asrt.t = raise (Failure "ERROR: to_assertions called for concrete executions") let run_spec @@ -209,7 +209,7 @@ end = struct let can_fix (_ : err_t) : bool = false let get_failing_constraint (_ : err_t) : Formula.t = True - let get_fixes (_ : err_t) : Asrt.t list list = + let get_fixes (_ : err_t) : Asrt.t list = raise (Failure "Concrete: get_fixes not implemented in CState.Make") let get_equal_values _ vs = vs diff --git a/GillianCore/engine/general_semantics/state.ml b/GillianCore/engine/general_semantics/state.ml index c677d0e4..37ec1701 100644 --- a/GillianCore/engine/general_semantics/state.ml +++ b/GillianCore/engine/general_semantics/state.ml @@ -107,7 +107,7 @@ module type S = sig val get_lvars : t -> Var.Set.t (** Turns a state into a list of assertions *) - val to_assertions : ?to_keep:Containers.SS.t -> t -> Asrt.t list + val to_assertions : ?to_keep:Containers.SS.t -> t -> Asrt.t val evaluate_slcmd : 'a MP.prog -> SLCmd.t -> t -> (t, err_t) Res_list.t @@ -144,7 +144,7 @@ module type S = sig val mem_constraints : t -> Formula.t list val can_fix : err_t -> bool val get_failing_constraint : err_t -> Formula.t - val get_fixes : err_t -> Asrt.t list list + val get_fixes : err_t -> Asrt.t list val get_equal_values : t -> vt list -> vt list val get_heap : t -> heap_t end diff --git a/GillianCore/engine/general_semantics/stateErr.ml b/GillianCore/engine/general_semantics/stateErr.ml index 88375c25..732f26d2 100644 --- a/GillianCore/engine/general_semantics/stateErr.ml +++ b/GillianCore/engine/general_semantics/stateErr.ml @@ -7,7 +7,7 @@ type ('mem_err, 'value) t = (** Incorrect type, depends on value *) | EPure of Formula.t (* Missing formula that should be true *) | EVar of Var.t (* Undefined variable *) - | EAsrt of ('value list * Formula.t * Asrt.t list list) + | EAsrt of ('value list * Formula.t * Asrt.t list) | EOther of string (* We want all errors to be proper errors - this is a temporary placeholder *) [@@deriving yojson, show] @@ -39,9 +39,7 @@ let pp_err | EPure f -> Fmt.pf fmt "EPure(%a)" Formula.pp f | EVar x -> Fmt.pf fmt "EVar(%s)" x | EAsrt (vs, f, asrtss) -> - let pp_asrts fmt asrts = - Fmt.pf fmt "[%a]" (Fmt.list ~sep:(Fmt.any ", ") Asrt.pp) asrts - in + let pp_asrts fmt asrts = Fmt.pf fmt "[%a]" Asrt.pp asrts in Fmt.pf fmt "EAsrt(%a; %a; %a)" (Fmt.list ~sep:(Fmt.any ", ") pp_v) vs Formula.pp f diff --git a/GillianCore/engine/symbolic_semantics/Legacy_s_memory.ml b/GillianCore/engine/symbolic_semantics/Legacy_s_memory.ml index 07fd9b00..d2317315 100644 --- a/GillianCore/engine/symbolic_semantics/Legacy_s_memory.ml +++ b/GillianCore/engine/symbolic_semantics/Legacy_s_memory.ml @@ -59,13 +59,13 @@ module type S = sig val clean_up : ?keep:Expr.Set.t -> t -> Expr.Set.t * Expr.Set.t val lvars : t -> Containers.SS.t val alocs : t -> Containers.SS.t - val assertions : ?to_keep:Containers.SS.t -> t -> Asrt.t list + val assertions : ?to_keep:Containers.SS.t -> t -> Asrt.t val mem_constraints : t -> Formula.t list val get_recovery_tactic : t -> err_t -> vt Recovery_tactic.t val pp_err : Format.formatter -> err_t -> unit val get_failing_constraint : err_t -> Formula.t val can_fix : err_t -> bool - val get_fixes : err_t -> Asrt.t list list + val get_fixes : err_t -> Asrt.t list val sure_is_nonempty : t -> bool end diff --git a/GillianCore/engine/symbolic_semantics/SMemory.ml b/GillianCore/engine/symbolic_semantics/SMemory.ml index 0ca184d6..86267bea 100644 --- a/GillianCore/engine/symbolic_semantics/SMemory.ml +++ b/GillianCore/engine/symbolic_semantics/SMemory.ml @@ -54,12 +54,12 @@ module type S = sig val clean_up : ?keep:Expr.Set.t -> t -> Expr.Set.t * Expr.Set.t val lvars : t -> Containers.SS.t val alocs : t -> Containers.SS.t - val assertions : ?to_keep:Containers.SS.t -> t -> Asrt.t list + val assertions : ?to_keep:Containers.SS.t -> t -> Asrt.t val mem_constraints : t -> Formula.t list val get_recovery_tactic : t -> err_t -> vt Recovery_tactic.t val pp_err : Format.formatter -> err_t -> unit val get_failing_constraint : err_t -> Formula.t - val get_fixes : err_t -> Asrt.t list list + val get_fixes : err_t -> Asrt.t list val can_fix : err_t -> bool val sure_is_nonempty : t -> bool diff --git a/GillianCore/engine/symbolic_semantics/SState.ml b/GillianCore/engine/symbolic_semantics/SState.ml index 9b6b0526..2fa905f0 100644 --- a/GillianCore/engine/symbolic_semantics/SState.ml +++ b/GillianCore/engine/symbolic_semantics/SState.ml @@ -507,7 +507,7 @@ module Make (SMemory : SMemory.S) : |> SS.union (Type_env.lvars gamma) |> SS.union spec_vars - let to_assertions ?(to_keep : SS.t option) (state : t) : Asrt.t list = + let to_assertions ?(to_keep : SS.t option) (state : t) : Asrt.t = let { heap; store; pfs; gamma; _ } = state in let store' = Option.fold @@ -714,18 +714,16 @@ module Make (SMemory : SMemory.S) : (* get_fixes returns a list of possible fixes. Each "fix" is actually a list of assertions, each of which have to be applied to the same state *) - let get_fixes (err : err_t) : Asrt.t list list = - let pp_fixes fmt fixes = - Fmt.pf fmt "[[ %a ]]" (Fmt.list ~sep:(Fmt.any ", ") Asrt.pp) fixes - in - let one_step_fixes : Asrt.t list list = + let get_fixes (err : err_t) : Asrt.t list = + let pp_fix fmt fix = Fmt.pf fmt "[[ %a ]]" Asrt.pp fix in + let one_step_fixes : Asrt.t list = match err with | EMem err -> SMemory.get_fixes err | EPure f -> let result = [ [ Asrt.Pure f ] ] in L.verbose (fun m -> m "@[Memory: Fixes found:@\n%a@]" - (Fmt.list ~sep:(Fmt.any "@\n") pp_fixes) + (Fmt.list ~sep:(Fmt.any "@\n") pp_fix) result); result | EAsrt (_, _, fixes) -> @@ -741,7 +739,7 @@ module Make (SMemory : SMemory.S) : in L.verbose (fun m -> m "@[Memory: Fixes found:@\n%a@]" - (Fmt.list ~sep:(Fmt.any "@\n") pp_fixes) + (Fmt.list ~sep:(Fmt.any "@\n") pp_fix) result); result | _ -> raise (Failure "DEATH: get_fixes: error cannot be fixed.") @@ -749,7 +747,7 @@ module Make (SMemory : SMemory.S) : L.tmi (fun m -> m "All fixes before normalisation: %a" - Fmt.Dump.(list @@ list @@ Asrt.pp) + Fmt.Dump.(list @@ Asrt.pp) one_step_fixes); List.map (fun fixes -> diff --git a/GillianCore/monadic/MonadicSMemory.ml b/GillianCore/monadic/MonadicSMemory.ml index c53d1376..c657baca 100644 --- a/GillianCore/monadic/MonadicSMemory.ml +++ b/GillianCore/monadic/MonadicSMemory.ml @@ -42,12 +42,12 @@ module type S = sig val clean_up : ?keep:Expr.Set.t -> t -> Expr.Set.t * Expr.Set.t val lvars : t -> Containers.SS.t val alocs : t -> Containers.SS.t - val assertions : ?to_keep:Containers.SS.t -> t -> Asrt.t list + val assertions : ?to_keep:Containers.SS.t -> t -> Asrt.t val mem_constraints : t -> Formula.t list val get_recovery_tactic : t -> err_t -> vt Recovery_tactic.t val pp_err : Format.formatter -> err_t -> unit val get_failing_constraint : err_t -> Formula.t - val get_fixes : err_t -> Asrt.t list list + val get_fixes : err_t -> Asrt.t list val can_fix : err_t -> bool val pp_by_need : Containers.SS.t -> Format.formatter -> t -> unit val get_print_info : Containers.SS.t -> t -> Containers.SS.t * Containers.SS.t @@ -67,7 +67,7 @@ module Lift (MSM : S) : include MSM let assertions ?to_keep t = - List.map Engine.Reduction.reduce_assertion (assertions ?to_keep t) + Engine.Reduction.reduce_assertion (assertions ?to_keep t) let execute_action action_name mem gpc params = let open Syntaxes.List in diff --git a/kanillian/lib/compiler/logics.ml b/kanillian/lib/compiler/logics.ml index 259881b4..19153cc4 100644 --- a/kanillian/lib/compiler/logics.ml +++ b/kanillian/lib/compiler/logics.ml @@ -2,7 +2,6 @@ open Gil_syntax module GType = Goto_lib.Type let rec asrt_of_scalar_like ~ctx (type_ : GType.t) (expr : Expr.t) : Asrt.t = - let open Asrt.Infix in match type_ with | CInteger I_bool -> (* Special case, the bounds are different *) @@ -12,7 +11,7 @@ let rec asrt_of_scalar_like ~ctx (type_ : GType.t) (expr : Expr.t) : Asrt.t = expr #== Expr.one_i #|| (expr #== Expr.zero_i) in let asrt_range = Asrt.Pure condition in - assume_int ** asrt_range + [ assume_int; asrt_range ] | CInteger _ | Signedbv _ | Unsignedbv _ -> let assume_int = Asrt.Types [ (expr, IntType) ] in let bounds = @@ -28,8 +27,8 @@ let rec asrt_of_scalar_like ~ctx (type_ : GType.t) (expr : Expr.t) : Asrt.t = in Asrt.Pure condition in - assume_int ** assume_range - | Double | Float -> Asrt.Types [ (expr, NumberType) ] + [ assume_int; assume_range ] + | Double | Float -> [ Asrt.Types [ (expr, NumberType) ] ] | Pointer _ -> let loc = LVar.alloc () in let ofs = LVar.alloc () in @@ -40,8 +39,8 @@ let rec asrt_of_scalar_like ~ctx (type_ : GType.t) (expr : Expr.t) : Asrt.t = Asrt.Pure f in let types = Asrt.Types [ (e_loc, ObjectType); (e_ofs, IntType) ] in - assume_list ** types - | Bool -> Asrt.Types [ (expr, BooleanType) ] + [ assume_list; types ] + | Bool -> [ Asrt.Types [ (expr, BooleanType) ] ] | StructTag _ | Struct _ -> let ty = let fields = Ctx.resolve_struct_components ctx type_ in @@ -56,11 +55,10 @@ let rec asrt_of_scalar_like ~ctx (type_ : GType.t) (expr : Expr.t) : Asrt.t = let assumption_of_param ~ctx ~(v : Var.t) ~(ty : GType.t) = (* The logic of what formulaes is generated should be factorised with [Compiled_expr.nondet_expr] *) - let open Asrt.Infix in if Ctx.representable_in_store ctx ty then let e_s = Expr.LVar (LVar.alloc ()) in let f = Formula.Eq (Expr.PVar v, e_s) in - Asrt.Pure f ** asrt_of_scalar_like ~ctx ty e_s + Asrt.Pure f :: asrt_of_scalar_like ~ctx ty e_s else failwith "unhandled: composit parameter" let assumption_of_ret_by_copy ~ctx ty = @@ -71,11 +69,11 @@ let assumption_of_ret_by_copy ~ctx ty = ~perm:(Some Freeable) in let types = Asrt.Types [ (loc, ObjectType) ] in - Asrt.Star (types, hole) + [ types; hole ] let bispec ~ctx ~(compiled : (K_annot.t, string) Proc.t) (f : Program.Func.t) = let ret_type_assume = - if Ctx.representable_in_store ctx f.return_type then Asrt.Emp + if Ctx.representable_in_store ctx f.return_type then [] else assumption_of_ret_by_copy ~ctx f.return_type in let param_names = @@ -88,7 +86,7 @@ let bispec ~ctx ~(compiled : (K_annot.t, string) Proc.t) (f : Program.Func.t) = (fun v Param.{ type_ = ty; _ } -> assumption_of_param ~ctx ~v ~ty) param_names f.params in - let pre = List.fold_left Asrt.Infix.( ** ) ret_type_assume param_asrts in + let pre = ret_type_assume @ List.flatten param_asrts in BiSpec. { bispec_name = compiled.proc_name; diff --git a/kanillian/lib/memory_model/GEnv.mli b/kanillian/lib/memory_model/GEnv.mli index 6723bb82..5e4affdc 100644 --- a/kanillian/lib/memory_model/GEnv.mli +++ b/kanillian/lib/memory_model/GEnv.mli @@ -39,7 +39,7 @@ module Concrete : sig (** {3 Symbolic things} *) val substitution : Gillian.Symbolic.Subst.t -> t -> t - val assertions : t -> string list * Gillian.Gil_syntax.Asrt.t list + val assertions : t -> string list * Gillian.Gil_syntax.Asrt.t end module Symbolic : sig @@ -79,5 +79,5 @@ module Symbolic : sig (** {3 Symbolic things} *) val substitution : Gillian.Symbolic.Subst.t -> t -> t - val assertions : t -> string list * Gillian.Gil_syntax.Asrt.t list + val assertions : t -> string list * Gillian.Gil_syntax.Asrt.t end diff --git a/kanillian/lib/memory_model/SHeapTree.mli b/kanillian/lib/memory_model/SHeapTree.mli index e0e13f8e..40a91970 100644 --- a/kanillian/lib/memory_model/SHeapTree.mli +++ b/kanillian/lib/memory_model/SHeapTree.mli @@ -74,7 +74,7 @@ val weak_valid_pointer : t -> Expr.t -> bool d_or_error [dst_tree] after modification *) val move : t -> Expr.t -> t -> Expr.t -> Expr.t -> t d_or_error -val assertions : loc:string -> t -> Asrt.t list +val assertions : loc:string -> t -> Asrt.t val substitution : le_subst:(Expr.t -> Expr.t) -> diff --git a/kanillian/lib/memory_model/predicates.ml b/kanillian/lib/memory_model/predicates.ml index 26cf9c72..80a296fc 100644 --- a/kanillian/lib/memory_model/predicates.ml +++ b/kanillian/lib/memory_model/predicates.ml @@ -3,7 +3,7 @@ open Gil_syntax module Core = struct let pred ga ins outs = let ga_name = Interface.str_ga ga in - Asrt.GA (ga_name, ins, outs) + Asrt.CorePred (ga_name, ins, outs) let single ~loc ~ofs ~chunk ~sval ~perm = let chunk = Expr.Lit (String (Chunk.to_string chunk)) in diff --git a/wisl/lib/ParserAndCompiler/wisl2Gil.ml b/wisl/lib/ParserAndCompiler/wisl2Gil.ml index b7cc2a06..7f7ab1e4 100644 --- a/wisl/lib/ParserAndCompiler/wisl2Gil.ml +++ b/wisl/lib/ParserAndCompiler/wisl2Gil.ml @@ -150,7 +150,7 @@ let rec compile_expr ?(fname = "main") ?(is_loop_prefix = false) expr : compiles a WLExpr into an output expression and a list of Global Assertions. the string list contains the name of the variables that are generated. They are existentials. *) let rec compile_lexpr ?(fname = "main") (lexpr : WLExpr.t) : - string list * Asrt.t list * Expr.t = + string list * Asrt.t * Expr.t = let gen_str = Generators.gen_str fname in let compile_lexpr = compile_lexpr ~fname in let expr_pname_of_binop b = @@ -237,7 +237,7 @@ let rec compile_lexpr ?(fname = "main") (lexpr : WLExpr.t) : (List.concat gvars, List.concat asrtsl, Expr.ESet comp_exprs)) (* TODO: compile_lformula should return also the list of created existentials *) -let rec compile_lformula ?(fname = "main") formula : Asrt.t list * Formula.t = +let rec compile_lformula ?(fname = "main") formula : Asrt.t * Formula.t = let gen_str = Generators.gen_str fname in let compile_lformula = compile_lformula ~fname in let compile_lexpr = compile_lexpr ~fname in @@ -295,7 +295,6 @@ let rec compile_lassert ?(fname = "main") asser : string list * Asrt.t = let gen_str = Generators.gen_str fname in let compile_lexpr = compile_lexpr ~fname in let compile_lformula = compile_lformula ~fname in - let concat_star = List.fold_left (fun a1 a2 -> Asrt.Star (a1, a2)) in let gil_add e k = (* builds GIL expression that is e + k *) let k_e = Expr.int k in @@ -362,9 +361,8 @@ let rec compile_lassert ?(fname = "main") asser : string list * Asrt.t = | [ le ] -> let exs2, la2, e2 = compile_lexpr le in ( exs1 @ exs2, - concat_star - (Asrt.GA (cell, [ eloc; eoffs ], [ e2 ])) - (bound @ la1 @ la2) ) + Asrt.CorePred (cell, [ eloc; eoffs ], [ e2 ]) :: (bound @ la1 @ la2) + ) | le :: r -> let exs2, la2, e2 = compile_lexpr le in let exs3, la3 = @@ -373,47 +371,42 @@ let rec compile_lassert ?(fname = "main") asser : string list * Asrt.t = le1 r ~curr:(curr + 1) in ( exs1 @ exs2 @ exs3, - concat_star - (Asrt.GA (cell, [ eloc; eoffs ], [ e2 ])) - (bound @ (la3 :: (la1 @ la2))) ) + Asrt.CorePred (cell, [ eloc; eoffs ], [ e2 ]) + :: (bound @ la1 @ la2 @ la3) ) in WLAssert.( match get asser with - | LEmp -> ([], Asrt.Emp) + | LEmp -> ([], []) | LStar (la1, la2) -> let exs1, cla1 = compile_lassert la1 in let exs2, cla2 = compile_lassert la2 in - (exs1 @ exs2, Asrt.Star (cla1, cla2)) + (exs1 @ exs2, cla1 @ cla2) | LPointsTo (le1, lle) -> compile_pointsto ~block:false le1 lle | LBlockPointsTo (le1, lle) -> compile_pointsto ~block:true le1 lle | LPred (pr, lel) -> let exsl, all, el = list_split_3 (List.map compile_lexpr lel) in let exs = List.concat exsl in let al = List.concat all in - (exs, concat_star (Asrt.Pred (pr, el)) al) + (exs, Asrt.Pred (pr, el) :: al) | LWand { lhs = lname, largs; rhs = rname, rargs } -> let exs1, al1, el1 = list_split_3 (List.map compile_lexpr largs) in let exs2, al2, el2 = list_split_3 (List.map compile_lexpr rargs) in let exs = List.concat (exs1 @ exs2) in let al = List.concat (al1 @ al2) in - ( exs, - concat_star (Asrt.Wand { lhs = (lname, el1); rhs = (rname, el2) }) al - ) + (exs, Asrt.Wand { lhs = (lname, el1); rhs = (rname, el2) } :: al) | LPure lf -> let al, f = compile_lformula lf in - ([], concat_star (Asrt.Pure f) al)) + ([], Asrt.Pure f :: al)) let rec compile_lcmd ?(fname = "main") lcmd = let compile_lassert = compile_lassert ~fname in let compile_lcmd = compile_lcmd ~fname in let compile_lexpr = compile_lexpr ~fname in - let concat_star = List.fold_left (fun a1 a2 -> Asrt.Star (a1, a2)) in let build_assert existentials lasrts = match lasrts with | [] -> None - | a :: r -> - let to_assert = concat_star a r in - let cmd = LCmd.SL (SLCmd.SepAssert (to_assert, existentials)) in + | _ -> + let cmd = LCmd.SL (SLCmd.SepAssert (lasrts, existentials)) in (* assert (assertions) {existentials: gvars} *) Some cmd in @@ -1174,8 +1167,8 @@ let compile ~filepath WProg.{ context; predicates; lemmas } = List.map (fun var -> Asrt.Pure (Eq (Expr.PVar var, Expr.LVar ("#" ^ var)))) proc.Proc.proc_params - |> Asrt.star in + let bispec = BiSpec. { diff --git a/wisl/lib/semantics/constr.ml b/wisl/lib/semantics/constr.ml index 76eb85db..317da920 100644 --- a/wisl/lib/semantics/constr.ml +++ b/wisl/lib/semantics/constr.ml @@ -3,13 +3,13 @@ open Gil_syntax let cell ~loc ~offset ~value = let cell = str_ga Cell in - Asrt.GA (cell, [ loc; offset ], [ value ]) + Asrt.CorePred (cell, [ loc; offset ], [ value ]) let bound ~loc ~bound = let bound_ga = str_ga Bound in let bound = Expr.int bound in - Asrt.GA (bound_ga, [ loc ], [ bound ]) + Asrt.CorePred (bound_ga, [ loc ], [ bound ]) let freed ~loc = let freed = str_ga Freed in - Asrt.GA (freed, [ loc ], []) + Asrt.CorePred (freed, [ loc ], []) diff --git a/wisl/lib/semantics/wislSHeap.mli b/wisl/lib/semantics/wislSHeap.mli index e8f919f9..6fad4af1 100644 --- a/wisl/lib/semantics/wislSHeap.mli +++ b/wisl/lib/semantics/wislSHeap.mli @@ -56,7 +56,7 @@ val substitution_in_place : * (string * Gillian.Gil_syntax.Type.t) list) list -val assertions : t -> Gillian.Gil_syntax.Asrt.t list +val assertions : t -> Gillian.Gil_syntax.Asrt.t val add_debugger_variables : store:(string * Gillian.Gil_syntax.Expr.t) list -> diff --git a/wisl/lib/semantics/wislSMemory.ml b/wisl/lib/semantics/wislSMemory.ml index 512a198e..9fc830a2 100644 --- a/wisl/lib/semantics/wislSMemory.ml +++ b/wisl/lib/semantics/wislSMemory.ml @@ -311,7 +311,7 @@ let get_fixes (err : err_t) = let value = Expr.LVar new_var in let loc = Expr.loc_from_loc_name loc in let ga = WislLActions.str_ga WislLActions.Cell in - [ [ Asrt.GA (ga, [ loc; ofs ], [ value ]) ] ] + [ [ Asrt.CorePred (ga, [ loc; ofs ], [ value ]) ] ] | InvalidLocation loc -> let new_loc = ALoc.alloc () in let new_expr = Expr.ALoc new_loc in From 45a659517d806c40adcb810bf84aad808d8e18ae Mon Sep 17 00:00:00 2001 From: N1ark Date: Sun, 15 Sep 2024 23:46:01 +0100 Subject: [PATCH 03/54] Fix C-gen for emp --- Gillian-C/lib/gil_logic_gen.ml | 2 +- .../engine/Abstraction/LogicPreprocessing.ml | 13 ++++++------- GillianCore/engine/Abstraction/MP.ml | 2 +- GillianCore/engine/FOLogic/Reduction.ml | 4 ++-- GillianCore/engine/FOLogic/Simplifications.ml | 3 +-- 5 files changed, 11 insertions(+), 13 deletions(-) diff --git a/Gillian-C/lib/gil_logic_gen.ml b/Gillian-C/lib/gil_logic_gen.ml index 4393c844..0939fa16 100644 --- a/Gillian-C/lib/gil_logic_gen.ml +++ b/Gillian-C/lib/gil_logic_gen.ml @@ -640,7 +640,7 @@ let rec trans_asrt ~fname ~ann asrt = | Pred (p, cel) -> let ap, _, gel = split3_expr_comp (List.map trans_expr cel) in Pred (p, gel) :: Asrt.star ap - | Emp -> [] + | Emp -> [ Asrt.Emp ] | PointsTo { ptr = s; constr = c; typ } -> trans_constr ~fname ~typ ann s c let rec trans_lcmd ~fname ~ann lcmd = diff --git a/GillianCore/engine/Abstraction/LogicPreprocessing.ml b/GillianCore/engine/Abstraction/LogicPreprocessing.ml index 59c6d2ad..56a465e0 100644 --- a/GillianCore/engine/Abstraction/LogicPreprocessing.ml +++ b/GillianCore/engine/Abstraction/LogicPreprocessing.ml @@ -272,15 +272,15 @@ let unfold_spec (preds : (string, Pred.t) Hashtbl.t) (rec_info : (string, bool) Hashtbl.t) (spec : Spec.t) : Spec.t = - let aux spec_name (sspec : Spec.st) : Spec.st list = + let aux (sspec : Spec.st) : Spec.st list = let pres : Asrt.t list = auto_unfold preds rec_info sspec.ss_pre in - L.verbose (fun fmt -> fmt "Pre admissibility: %s" spec_name); + L.verbose (fun fmt -> fmt "Pre admissibility: %s" spec.spec_name); let pres = List.filter Simplifications.admissible_assertion pres in let posts : Asrt.t list = List.concat_map (auto_unfold preds rec_info) sspec.ss_posts in let posts = List.map Reduction.reduce_assertion posts in - L.verbose (fun fmt -> fmt "Post admissibility: %s" spec_name); + L.verbose (fun fmt -> fmt "Post admissibility: %s" spec.spec_name); L.tmi (fun fmt -> fmt "@[Testing admissibility for assertions:@.%a@]" (Fmt.list Asrt.pp) posts); @@ -289,14 +289,12 @@ let unfold_spec Fmt.failwith "Unfolding: Postcondition of %s seems invalid, it has been reduced to \ no postcondition" - spec_name; + spec.spec_name; List.map (fun pre -> Spec.{ sspec with ss_pre = pre; ss_posts = posts }) pres in - let spec_sspecs = - List.concat (List.map (aux spec.spec_name) spec.spec_sspecs) - in + let spec_sspecs = List.concat_map aux spec.spec_sspecs in match spec_sspecs with | [] -> Fmt.failwith "unfolding in spec at preprocessing led to no spec!" | _ -> @@ -415,6 +413,7 @@ let unfold_proc (preds : (string, Pred.t) Hashtbl.t) (rec_info : (string, bool) Hashtbl.t) (proc : ('a, int) Proc.t) : ('a, int) Proc.t = + Logging.normal (fun f -> f "UNFOLD_PROC ! %a" Proc.pp_indexed proc); let new_spec = Option.map (unfold_spec preds rec_info) proc.proc_spec in let new_body = Array.map diff --git a/GillianCore/engine/Abstraction/MP.ml b/GillianCore/engine/Abstraction/MP.ml index 209e2773..2dd3aeaa 100644 --- a/GillianCore/engine/Abstraction/MP.ml +++ b/GillianCore/engine/Abstraction/MP.ml @@ -930,7 +930,7 @@ let pp_asrt (Pred.pp_ins_outs pred.pred Expr.pp pp_out_params_args) (in_args, out_params_args) with _ -> Asrt.pp fmt a)) - | a -> Asrt.pp_simple_full fmt a + | a -> Asrt.pp_simple fmt a in Fmt.list ~sep:(Fmt.any " *@ ") pp_simple_asrt fmt a diff --git a/GillianCore/engine/FOLogic/Reduction.ml b/GillianCore/engine/FOLogic/Reduction.ml index ddbbd758..3f37bb8a 100644 --- a/GillianCore/engine/FOLogic/Reduction.ml +++ b/GillianCore/engine/FOLogic/Reduction.ml @@ -3226,8 +3226,8 @@ let reduce_assertion_loop List.fold_right (fun (e, t) ac -> match (e : Expr.t) with - | Lit lit -> - if t <> Literal.type_of lit then raise WrongType else ac + | Lit lit when t <> Literal.type_of lit -> raise WrongType + | Lit _ -> ac | _ -> (e, t) :: ac) lvt [] in diff --git a/GillianCore/engine/FOLogic/Simplifications.ml b/GillianCore/engine/FOLogic/Simplifications.ml index b3d4c62a..02bf2d3b 100644 --- a/GillianCore/engine/FOLogic/Simplifications.ml +++ b/GillianCore/engine/FOLogic/Simplifications.ml @@ -1012,8 +1012,7 @@ let admissible_assertion (a : Asrt.t) : bool = List.iter separate a; let _ = simplify_pfs_and_gamma ~kill_new_lvars:true pfs gamma in let res = not (PFS.mem pfs Formula.False) in - if res then L.tmi (fun m -> m "Admissible !!") - else L.tmi (fun m -> m "Not admissible !!"); + L.tmi (fun m -> m "Admissible? %b" res); res with e -> L.tmi (fun m -> From 3ab57e2a6ab7873f6076a1674e00964a4e616d3b Mon Sep 17 00:00:00 2001 From: N1ark Date: Mon, 16 Sep 2024 15:41:04 +0100 Subject: [PATCH 04/54] Merge branch 'fix-fixes' into asrt-as-list From 1b60fb96ba1716ceb28c1da9e171c7a45497b347 Mon Sep 17 00:00:00 2001 From: N1ark Date: Tue, 17 Sep 2024 14:38:51 +0100 Subject: [PATCH 05/54] Simplify stuff --- Gillian-C/lib/gil_logic_gen.ml | 25 ++---- Gillian-JS/lib/Compiler/JSIL_PostParser.ml | 2 +- GillianCore/GIL_Syntax/Asrt.ml | 66 ++++----------- GillianCore/GIL_Syntax/Gil_syntax.mli | 32 ++------ GillianCore/GIL_Syntax/LCmd.ml | 37 +++------ GillianCore/GIL_Syntax/Lemma.ml | 38 +-------- GillianCore/GIL_Syntax/Pred.ml | 82 +++++++++---------- GillianCore/GIL_Syntax/SLCmd.ml | 37 +++------ GillianCore/GIL_Syntax/Spec.ml | 45 +--------- GillianCore/engine/Abstraction/MP.ml | 26 ++---- GillianCore/engine/Abstraction/MP.mli | 2 +- GillianCore/engine/Abstraction/Matcher.ml | 2 +- GillianCore/engine/Abstraction/PState.ml | 6 +- GillianCore/engine/BiAbduction/BiState.ml | 6 +- GillianCore/engine/general_semantics/subst.ml | 34 +++----- 15 files changed, 128 insertions(+), 312 deletions(-) diff --git a/Gillian-C/lib/gil_logic_gen.ml b/Gillian-C/lib/gil_logic_gen.ml index 0939fa16..0133edc3 100644 --- a/Gillian-C/lib/gil_logic_gen.ml +++ b/Gillian-C/lib/gil_logic_gen.ml @@ -30,7 +30,7 @@ let rec split3_expr_comp = function | [] -> ([], [], []) | (x, y, z) :: l -> let rx, ry, rz = split3_expr_comp l in - (x :: rx, y @ ry, z :: rz) + (x @ rx, y @ ry, z :: rz) let ( ++ ) = Expr.Infix.( + ) @@ -380,12 +380,10 @@ let rec trans_expr (e : CExpr.t) : Asrt.t * Var.t list * Expr.t = | CExpr.SExpr se -> ([], [], trans_simpl_expr se) | SVal sv -> trans_sval sv | EList el -> - let asrts, vars, elp = split3_expr_comp (List.map trans_expr el) in - let asrt = Asrt.star asrts in + let asrt, vars, elp = split3_expr_comp (List.map trans_expr el) in (asrt, vars, Expr.EList elp) | ESet es -> - let asrts, vars, elp = split3_expr_comp (List.map trans_expr es) in - let asrt = Asrt.star asrts in + let asrt, vars, elp = split3_expr_comp (List.map trans_expr es) in (asrt, vars, Expr.ESet elp) | BinOp (e1, LstCat, e2) -> let a1, v1, eg1 = trans_expr e1 in @@ -415,8 +413,7 @@ let rec trans_expr (e : CExpr.t) : Asrt.t * Var.t list * Expr.t = let a, v, eg = trans_expr e in (a, v, UnOp (trans_unop u, eg)) | NOp (nop, el) -> - let asrts, vs, elp = split3_expr_comp (List.map trans_expr el) in - let asrt = Asrt.star asrts in + let asrt, vs, elp = split3_expr_comp (List.map trans_expr el) in let gnop = trans_nop nop in (asrt, vs, Expr.NOp (gnop, elp)) | LstSub (lst, start, len) -> @@ -598,8 +595,7 @@ let trans_constr ?fname:_ ~(typ : CAssert.points_to_type) ann s c = split3_expr_comp (List.map trans_expr el) in let pr = - Asrt.Pred (struct_pred, [ locv; ofsv ] @ params_fields) - :: Asrt.star more_asrt + Asrt.Pred (struct_pred, [ locv; ofsv ] @ params_fields) :: more_asrt in [ malloc_chunk siz ] @ pr @ to_assert @@ -639,7 +635,7 @@ let rec trans_asrt ~fname ~ann asrt = Pure fp :: ma | Pred (p, cel) -> let ap, _, gel = split3_expr_comp (List.map trans_expr cel) in - Pred (p, gel) :: Asrt.star ap + Pred (p, gel) :: ap | Emp -> [ Asrt.Emp ] | PointsTo { ptr = s; constr = c; typ } -> trans_constr ~fname ~typ ann s c @@ -653,17 +649,14 @@ let rec trans_lcmd ~fname ~ann lcmd = match lcmd with | CLCmd.Apply (pn, el) -> let aps, bindings, gel = split3_expr_comp (List.map trans_expr el) in - let to_assert = Asrt.star aps in - `Normal (make_assert ~bindings to_assert @ [ SL (ApplyLem (pn, gel, [])) ]) + `Normal (make_assert ~bindings aps @ [ SL (ApplyLem (pn, gel, [])) ]) | CLCmd.Fold (pn, el) -> let aps, bindings, gel = split3_expr_comp (List.map trans_expr el) in - let to_assert = Asrt.star aps in - `Normal (make_assert ~bindings to_assert @ [ SL (Fold (pn, gel, None)) ]) + `Normal (make_assert ~bindings aps @ [ SL (Fold (pn, gel, None)) ]) | Unfold { pred; params; bindings; recursive } -> let ap, vs, gel = split3_expr_comp (List.map trans_expr params) in - let to_assert = Asrt.star ap in `Normal - (make_assert ~bindings:vs to_assert + (make_assert ~bindings:vs ap @ [ SL (Unfold (pred, gel, bindings, recursive)) ]) | Unfold_all pred_name -> `Normal [ SL (GUnfold pred_name) ] | Assert (a, ex) -> `Normal [ SL (SepAssert (trans_asrt a, ex)) ] diff --git a/Gillian-JS/lib/Compiler/JSIL_PostParser.ml b/Gillian-JS/lib/Compiler/JSIL_PostParser.ml index 5a2e3e57..0fbcca3a 100644 --- a/Gillian-JS/lib/Compiler/JSIL_PostParser.ml +++ b/Gillian-JS/lib/Compiler/JSIL_PostParser.ml @@ -199,8 +199,8 @@ let scope_info_to_assertion let this_asrt = make_this_assertion () in - let init_heap_asrt : Asrt.t = Pred (heap_asrt_name, []) in if fid <> JS2JSIL_Helpers.main_fid then + let init_heap_asrt : Asrt.t = Pred (heap_asrt_name, []) in Asrt.star (glob_constraints @ (this_asrt :: init_heap_asrt :: a_schain :: a_vars)) else Asrt.star (glob_constraints @ (this_asrt :: a_schain :: a_vars)) diff --git a/GillianCore/GIL_Syntax/Asrt.ml b/GillianCore/GIL_Syntax/Asrt.ml index 20b755e1..c8dc67f7 100644 --- a/GillianCore/GIL_Syntax/Asrt.ml +++ b/GillianCore/GIL_Syntax/Asrt.ml @@ -69,34 +69,19 @@ end module Set = Set.Make (MyAssertion) (** Deprecated, use {!Visitors.endo} instead. *) -let map - (f_a_before : (simple -> t) option) - (f_a_after : (simple -> t) option) - (f_e : (Expr.t -> Expr.t) option) - (f_p : (Formula.t -> Formula.t) option) - (a : t) : t = - (* Map recursively to assertions and expressions *) - let map_e = Option.value ~default:(fun x -> x) f_e in - let map_p = Option.value ~default:(Formula.map None None (Some map_e)) f_p in - let f_a_before = Option.value ~default:(fun x -> [ x ]) f_a_before in - let f_a_after = Option.value ~default:(fun x -> [ x ]) f_a_after in - let a' = List.concat_map f_a_before a in - - a' - |> List.map (function - | Emp -> Emp - | Pred (s, le) -> Pred (s, List.map map_e le) - | Pure form -> Pure (map_p form) - | Types lt -> Types (List.map (fun (exp, typ) -> (map_e exp, typ)) lt) - | CorePred (x, es1, es2) -> - CorePred (x, List.map map_e es1, List.map map_e es2) - | Wand { lhs = lhs_pred, lhs_args; rhs = rhs_pred, rhs_args } -> - Wand - { - lhs = (lhs_pred, List.map map_e lhs_args); - rhs = (rhs_pred, List.map map_e rhs_args); - }) - |> List.concat_map f_a_after +let map (f_e : Expr.t -> Expr.t) (f_p : Formula.t -> Formula.t) : t -> t = + List.map (function + | Emp -> Emp + | Pred (s, le) -> Pred (s, List.map f_e le) + | Pure form -> Pure (f_p form) + | Types lt -> Types (List.map (fun (exp, typ) -> (f_e exp, typ)) lt) + | CorePred (x, es1, es2) -> CorePred (x, List.map f_e es1, List.map f_e es2) + | Wand { lhs = lhs_pred, lhs_args; rhs = rhs_pred, rhs_args } -> + Wand + { + lhs = (lhs_pred, List.map f_e lhs_args); + rhs = (rhs_pred, List.map f_e rhs_args); + }) (* Get all the logical expressions of --a-- that denote a list and are not logical variables *) @@ -141,20 +126,11 @@ let pure_asrts : t -> Formula.t list = in collector#visit_assertion () -(* Returns a list with the simple assertions that occur in --a-- *) -(* TODO: remove *) -let simple_asrts : t -> t = List.filter (fun x -> x <> Emp) - (* Check if --a-- is a pure assertion *) let is_pure_asrt : simple -> bool = function | Pred _ | CorePred _ | Wand _ -> false | _ -> true -(* Check if --a-- is a pure assertion & non-recursive assertion. - It assumes that only pure assertions are universally quantified *) -(* TODO: remove *) -let is_pure_non_rec_asrt : simple -> bool = is_pure_asrt - (* Eliminate LStar and LTypes assertions. LTypes disappears. LStar is replaced by LAnd. This function expects its argument to be a PURE assertion. *) @@ -199,17 +175,11 @@ let pp = _pp ~e_pp:Expr.pp let full_pp = _pp ~e_pp:Expr.full_pp let subst_clocs (subst : string -> Expr.t) : t -> t = - map None None - (Some (Expr.subst_clocs subst)) - (Some (Formula.subst_clocs subst)) + map (Expr.subst_clocs subst) (Formula.subst_clocs subst) let subst_expr_for_expr ~(to_subst : Expr.t) ~(subst_with : Expr.t) : t -> t = - map None None - (Some (Expr.subst_expr_for_expr ~to_subst ~subst_with)) - (Some (Formula.subst_expr_for_expr ~to_subst ~subst_with)) - -let pvars_to_lvars : t -> t = - map None None (Some Expr.pvars_to_lvars) (Some Formula.pvars_to_lvars) + map + (Expr.subst_expr_for_expr ~to_subst ~subst_with) + (Formula.subst_expr_for_expr ~to_subst ~subst_with) -(* TODO: remove *) -let star : t list -> t = List.concat +let pvars_to_lvars : t -> t = map Expr.pvars_to_lvars Formula.pvars_to_lvars diff --git a/GillianCore/GIL_Syntax/Gil_syntax.mli b/GillianCore/GIL_Syntax/Gil_syntax.mli index 95059e3a..7d9b716e 100644 --- a/GillianCore/GIL_Syntax/Gil_syntax.mli +++ b/GillianCore/GIL_Syntax/Gil_syntax.mli @@ -585,13 +585,7 @@ module Asrt : sig module Set : Set.S with type elt := t (** @deprecated Use {!Visitors.endo} instead *) - val map : - (simple -> t) option -> - (simple -> t) option -> - (Expr.t -> Expr.t) option -> - (Formula.t -> Formula.t) option -> - t -> - t + val map : (Expr.t -> Expr.t) -> (Formula.t -> Formula.t) -> t -> t (** Get all the logical expressions of [a] that denote a list and are not logical variables *) @@ -618,16 +612,9 @@ module Asrt : sig (** Returns a list with the pure assertions that occur in [a] *) val pure_asrts : t -> Formula.t list - (** Returns a list with the pure assertions that occur in [a] *) - val simple_asrts : t -> t - (** Check if [a] is a pure assertion *) val is_pure_asrt : simple -> bool - (** Check if [a] is a pure assertion & non-recursive assertion. - It assumes that only pure assertions are universally quantified *) - val is_pure_non_rec_asrt : simple -> bool - (** Eliminate LStar and LTypes assertions. LTypes disappears. LStar is replaced by LAnd. This function expects its argument to be a PURE assertion. *) @@ -643,9 +630,6 @@ module Asrt : sig val pp_simple_full : Format.formatter -> simple -> unit - (** [star \[a1; a2; ...; an\] will return \[a1 * a2 * ... * an\]] *) - val star : t list -> t - (** [subst_clocs subst a] Substitutes expressions of the form [Lit (Loc l)] with [subst l] in [a] *) val subst_clocs : (string -> Expr.t) -> t -> t @@ -676,12 +660,7 @@ module SLCmd : sig | SymbExec (** @deprecated Use {!Visitors.endo} instead *) - val map : - (t -> t) option -> - (Asrt.t -> Asrt.t) option -> - (Expr.t -> Expr.t) option -> - t -> - t + val map : (Asrt.t -> Asrt.t) -> (Expr.t -> Expr.t) -> t -> t (** Pretty-printer of folding info *) val pp_folding_info : (string * (string * Expr.t) list) option Fmt.t @@ -708,10 +687,9 @@ module LCmd : sig (** @deprecated Use {!Visitors.endo} instead *) val map : - (t -> t) option -> - (Expr.t -> Expr.t) option -> - (Formula.t -> Formula.t) option -> - (SLCmd.t -> SLCmd.t) option -> + (Expr.t -> Expr.t) -> + (Formula.t -> Formula.t) -> + (SLCmd.t -> SLCmd.t) -> t -> t diff --git a/GillianCore/GIL_Syntax/LCmd.ml b/GillianCore/GIL_Syntax/LCmd.ml index 71242700..fbcb53e4 100644 --- a/GillianCore/GIL_Syntax/LCmd.ml +++ b/GillianCore/GIL_Syntax/LCmd.ml @@ -14,30 +14,19 @@ type t = TypeDef__.lcmd = [@@deriving yojson] let rec map - (f_l : (t -> t) option) - (f_e : (Expr.t -> Expr.t) option) - (f_p : (Formula.t -> Formula.t) option) - (f_sl : (SLCmd.t -> SLCmd.t) option) - (lcmd : t) : t = - (* Functions to map over formulas, expressions, and sl-commands *) - let f = map f_l f_e f_p f_sl in - let map_e = Option.value ~default:(fun x -> x) f_e in - let map_p = Option.value ~default:(fun x -> x) f_p in - let map_sl = Option.value ~default:(fun x -> x) f_sl in - - (* Apply the given function to the logical command *) - let mapped_lcmd = Option.fold ~some:(fun f -> f lcmd) ~none:lcmd f_l in - - (* Map over the elements of the command *) - match mapped_lcmd with - | Branch a -> Branch (map_p a) - | If (e, l1, l2) -> If (map_e e, List.map f l1, List.map f l2) - | Macro (s, l) -> Macro (s, List.map map_e l) - | Assume a -> Assume (map_p a) - | Assert a -> Assert (map_p a) - | AssumeType (e, t) -> AssumeType (map_e e, t) - | FreshSVar _ -> mapped_lcmd - | SL sl_cmd -> SL (map_sl sl_cmd) + (f_e : Expr.t -> Expr.t) + (f_p : Formula.t -> Formula.t) + (f_sl : SLCmd.t -> SLCmd.t) = + let f = map f_e f_p f_sl in + function + | Branch a -> Branch (f_p a) + | If (e, l1, l2) -> If (f_e e, List.map f l1, List.map f l2) + | Macro (s, l) -> Macro (s, List.map f_e l) + | Assume a -> Assume (f_p a) + | Assert a -> Assert (f_p a) + | AssumeType (e, t) -> AssumeType (f_e e, t) + | FreshSVar _ as lcmd -> lcmd + | SL sl_cmd -> SL (f_sl sl_cmd) let fold = List.fold_left SS.union SS.empty diff --git a/GillianCore/GIL_Syntax/Lemma.ml b/GillianCore/GIL_Syntax/Lemma.ml index 2db7eb03..de8f19e1 100644 --- a/GillianCore/GIL_Syntax/Lemma.ml +++ b/GillianCore/GIL_Syntax/Lemma.ml @@ -48,43 +48,11 @@ let pp fmt lemma = lemma.lemma_specs (Fmt.option pp_proof) lemma.lemma_proof let parameter_types (preds : (string, Pred.t) Hashtbl.t) (lemma : t) : t = - (* copied from spec - needs refactoring *) - let pt_asrt (a : Asrt.t) : Asrt.t = - let f_a_after (a : Asrt.simple) : Asrt.t = - match a with - | Pred (name, les) -> - let pred = - try Hashtbl.find preds name - with _ -> - raise - (Failure - ("DEATH. parameter_types: predicate " ^ name - ^ " does not exist.")) - in - (* Printf.printf "Pred: %s\n\tParams1: %s\n\tParams2: %s\n" name - (String.concat ", " (let x, _ = List.split pred.params in x)) (String.concat ", " (List.map (Fmt.to_to_string Expr.pp) les)); *) - let ac_types = - List.fold_left - (fun ac_types ((_, t_x), le) -> - match t_x with - | None -> ac_types - | Some t_x -> (le, t_x) :: ac_types) - [] - (try List.combine pred.pred_params les - with Invalid_argument _ -> - Fmt.failwith - "Invalid number of arguments: %a.\nInside of lemma: %s" - Asrt.pp_simple_full a lemma.lemma_name) - in - [ Types ac_types; a ] - | _ -> [ a ] - in - Asrt.map None (Some f_a_after) None None a - in + let map_asrts = Pred.extend_asrt_pred_types preds in let pt_spec { lemma_hyp; lemma_concs; lemma_spec_variant } = { - lemma_hyp = pt_asrt lemma_hyp; - lemma_concs = List.map pt_asrt lemma_concs; + lemma_hyp = map_asrts lemma_hyp; + lemma_concs = List.map map_asrts lemma_concs; lemma_spec_variant; } in diff --git a/GillianCore/GIL_Syntax/Pred.ml b/GillianCore/GIL_Syntax/Pred.ml index fe8f0ef6..4b62f345 100644 --- a/GillianCore/GIL_Syntax/Pred.ml +++ b/GillianCore/GIL_Syntax/Pred.ml @@ -177,54 +177,48 @@ let check_pvars (predicates : (string, t) Hashtbl.t) : unit = Hashtbl.iter check_pred_pvars predicates +let extend_asrt_pred_types (preds : (string, t) Hashtbl.t) : Asrt.t -> Asrt.t = + List.concat_map @@ function + | Asrt.Pred (name, les) as a -> + let pred = + try Hashtbl.find preds name + with _ -> + raise + (Failure + ("DEATH. parameter_types: predicate " ^ name ^ " does not exist.")) + in + Logging.tmi (fun fmt -> + fmt "Gillian explicit param types: %s (%d, %d)" pred.pred_name + (List.length pred.pred_params) + (List.length les)); + let combined = + try List.combine pred.pred_params les + with Invalid_argument _ -> + let message = + Fmt.str + "Invalid number of parameters for predicate %s which requires %i \ + parameters and was used with the following %i parameters: %a" + pred.pred_name pred.pred_num_params (List.length les) + (Fmt.Dump.list Expr.pp) les + in + raise (Invalid_argument message) + in + let ac_types = + List.fold_left + (fun ac_types ((_, t_x), le) -> + match t_x with + | None -> ac_types + | Some t_x -> (le, t_x) :: ac_types) + [] combined + in + [ Asrt.Types ac_types; a ] + | a -> [ a ] + (** GIL Predicates can have non-pvar parameters - to say that a given parameter always has a certain value... *) let explicit_param_types (preds : (string, t) Hashtbl.t) (pred : t) : t = - let pt_asrt (a : Asrt.t) : Asrt.t = - let f_a_after (a : Asrt.simple) : Asrt.t = - match a with - | Pred (name, les) -> - let pred = - try Hashtbl.find preds name - with _ -> - raise - (Failure - ("DEATH. parameter_types: predicate " ^ name - ^ " does not exist.")) - in - Logging.tmi (fun fmt -> - fmt "Gillian explicit param types: %s (%d, %d)" pred.pred_name - (List.length pred.pred_params) - (List.length les)); - let combined = - try List.combine pred.pred_params les - with Invalid_argument _ -> - let message = - Fmt.str - "Invalid number of parameters for predicate %s which \ - requires %i parameters and was used with the following %i \ - parameters: %a" - pred.pred_name pred.pred_num_params (List.length les) - (Fmt.Dump.list Expr.pp) les - in - raise (Invalid_argument message) - in - let ac_types = - List.fold_left - (fun ac_types ((_, t_x), le) -> - match t_x with - | None -> ac_types - | Some t_x -> (le, t_x) :: ac_types) - [] combined - in - [ Types ac_types; a ] - | _ -> [ a ] - in - Asrt.map None (Some f_a_after) None None a - in - let new_asrts = List.fold_right (fun (x, t_x) new_asrts -> @@ -235,7 +229,7 @@ let explicit_param_types (preds : (string, t) Hashtbl.t) (pred : t) : t = in let new_defs = List.map - (fun (oid, a) -> (oid, pt_asrt (a @ new_asrts))) + (fun (oid, a) -> (oid, extend_asrt_pred_types preds (a @ new_asrts))) pred.pred_definitions in let new_facts = diff --git a/GillianCore/GIL_Syntax/SLCmd.ml b/GillianCore/GIL_Syntax/SLCmd.ml index 43ba2d2e..584e5235 100644 --- a/GillianCore/GIL_Syntax/SLCmd.ml +++ b/GillianCore/GIL_Syntax/SLCmd.ml @@ -26,40 +26,23 @@ type t = TypeDef__.slcmd = | SymbExec [@@deriving yojson] -let map - (f_l : (t -> t) option) - (f_a : (Asrt.t -> Asrt.t) option) - (f_e : (Expr.t -> Expr.t) option) - (lcmd : t) : t = - (* Functions to map over assertions and expressions *) - let map_e = Option.value ~default:(fun x -> x) f_e in - let map_a = Option.value ~default:(fun x -> x) f_a in - - let mapped_lcmd = Option.fold ~some:(fun f -> f lcmd) ~none:lcmd f_l in - - (* Map over the elements of the command *) - match mapped_lcmd with - | Fold (name, les, None) -> Fold (name, List.map map_e les, None) +let map (f_a : Asrt.t -> Asrt.t) (f_e : Expr.t -> Expr.t) : t -> t = function + | Fold (name, les, None) -> Fold (name, List.map f_e les, None) | Fold (name, les, Some (s, l)) -> Fold - ( name, - List.map map_e les, - Some (s, List.map (fun (x, e) -> (x, map_e e)) l) ) + (name, List.map f_e les, Some (s, List.map (fun (x, e) -> (x, f_e e)) l)) | Unfold (name, les, unfold_info, b) -> - Unfold (name, List.map map_e les, unfold_info, b) + Unfold (name, List.map f_e les, unfold_info, b) | GUnfold name -> GUnfold name - | ApplyLem (s, l, existentials) -> ApplyLem (s, List.map map_e l, existentials) - | SepAssert (a, binders) -> SepAssert (map_a a, binders) - | Invariant (a, existentials) -> Invariant (map_a a, existentials) - | Consume (a, binders) -> Consume (map_a a, binders) - | Produce a -> Produce (map_a a) + | ApplyLem (s, l, existentials) -> ApplyLem (s, List.map f_e l, existentials) + | SepAssert (a, binders) -> SepAssert (f_a a, binders) + | Invariant (a, existentials) -> Invariant (f_a a, existentials) + | Consume (a, binders) -> Consume (f_a a, binders) + | Produce a -> Produce (f_a a) | SymbExec -> SymbExec | Package { lhs = lname, largs; rhs = rname, rargs } -> Package - { - lhs = (lname, List.map map_e largs); - rhs = (rname, List.map map_e rargs); - } + { lhs = (lname, List.map f_e largs); rhs = (rname, List.map f_e rargs) } let fold = List.fold_left SS.union SS.empty diff --git a/GillianCore/GIL_Syntax/Spec.ml b/GillianCore/GIL_Syntax/Spec.ml index 78f33a71..5dc96161 100644 --- a/GillianCore/GIL_Syntax/Spec.ml +++ b/GillianCore/GIL_Syntax/Spec.ml @@ -76,51 +76,12 @@ let pp fmt spec = spec.spec_sspecs let parameter_types (preds : (string, Pred.t) Hashtbl.t) (spec : t) : t = - let pt_asrt (a : Asrt.t) : Asrt.t = - let f_a_after (a : Asrt.simple) : Asrt.t = - match a with - | Pred (name, les) -> - let pred = - try Hashtbl.find preds name - with _ -> - raise - (Failure - ("DEATH. parameter_types: predicate " ^ name - ^ " does not exist.")) - in - (* Printf.printf "Pred: %s\n\tParams1: %s\n\tParams2: %s\n" name - (String.concat ", " (let x, _ = List.split pred.params in x)) (String.concat ", " (List.map (Fmt.to_to_string Expr.pp) les)); *) - let combined_params = - try List.combine pred.pred_params les - with Invalid_argument _ -> - let message = - Fmt.str - "Predicate %s is expecting %i arguments but is used with the \ - following %i arguments : %a" - pred.pred_name pred.pred_num_params (List.length les) - (Fmt.Dump.list Expr.pp) les - in - raise (Invalid_argument message) - in - let ac_types = - List.fold_left - (fun ac_types ((_, t_x), le) -> - match t_x with - | None -> ac_types - | Some t_x -> (le, t_x) :: ac_types) - [] combined_params - in - [ Types ac_types; a ] - | _ -> [ a ] - in - Asrt.map None (Some f_a_after) None None a - in - + let map_asrts = Pred.extend_asrt_pred_types preds in let pt_sspec (sspec : st) : st = { sspec with - ss_pre = pt_asrt sspec.ss_pre; - ss_posts = List.map pt_asrt sspec.ss_posts; + ss_pre = map_asrts sspec.ss_pre; + ss_posts = List.map map_asrts sspec.ss_posts; } in { spec with spec_sspecs = List.map pt_sspec spec.spec_sspecs } diff --git a/GillianCore/engine/Abstraction/MP.ml b/GillianCore/engine/Abstraction/MP.ml index 2dd3aeaa..8b8ee5c0 100644 --- a/GillianCore/engine/Abstraction/MP.ml +++ b/GillianCore/engine/Abstraction/MP.ml @@ -535,7 +535,7 @@ let ins_outs_assertion | _ -> raise (Failure "Impossible: non-simple assertion in ins_outs_assertion.") -let collect_simple_asrts a = +let simplify_asrts a = let rec aux (a : Asrt.simple) : Asrt.simple list = match a with | Pure True | Emp -> [] @@ -547,22 +547,12 @@ let collect_simple_asrts a = | [ Types les ] -> List.map (fun e -> Asrt.Types [ e ]) les | _ -> List.concat_map aux a) in - List.concat_map aux a - -let collect_and_simplify_atoms a = - let atoms = collect_simple_asrts a in - let atoms = - if List.mem (Asrt.Pure False) atoms then [ Asrt.Pure False ] else atoms - in - let separating, overlapping = - List.partition - (function - | Asrt.Pred _ | Asrt.CorePred _ | Asrt.Wand _ -> true - | _ -> false) - atoms - in - let overlapping = List.sort_uniq Stdlib.compare overlapping in - List.sort Asrt.prioritise (separating @ overlapping) + let atoms = List.concat_map aux a in + if List.mem (Asrt.Pure False) atoms then [ Asrt.Pure False ] + else + let overlapping, separating = List.partition Asrt.is_pure_asrt atoms in + let overlapping = List.sort_uniq Stdlib.compare overlapping in + List.sort Asrt.prioritise (separating @ overlapping) let s_init_atoms ~preds kb atoms = let step_of_atom ~kb atom = @@ -596,7 +586,7 @@ let s_init_atoms ~preds kb atoms = let s_init ~(preds : (string, int list) Hashtbl.t) (kb : KB.t) (a : Asrt.t) : (step list, Asrt.t) result = L.verbose (fun m -> m "Entering s-init on: %a\n\nKB: %a\n" Asrt.pp a kb_pp kb); - let atoms = collect_and_simplify_atoms a in + let atoms = simplify_asrts a in s_init_atoms ~preds kb atoms let of_step_list ?post ?label (steps : step list) : t = diff --git a/GillianCore/engine/Abstraction/MP.mli b/GillianCore/engine/Abstraction/MP.mli index dc45ccd5..df54af13 100644 --- a/GillianCore/engine/Abstraction/MP.mli +++ b/GillianCore/engine/Abstraction/MP.mli @@ -53,7 +53,7 @@ val learn_expr : ?top_level:bool -> KB.t -> Gil_syntax.Expr.t -> Gil_syntax.Expr.t -> outs val ins_outs_expr : KB.t -> Expr.t -> Expr.t -> (KB.t * outs) list -val collect_simple_asrts : Asrt.t -> Asrt.simple list +val simplify_asrts : Asrt.t -> Asrt.t val s_init_atoms : preds:(string, int list) Hashtbl.t -> diff --git a/GillianCore/engine/Abstraction/Matcher.ml b/GillianCore/engine/Abstraction/Matcher.ml index 1e7050ec..cd21b654 100644 --- a/GillianCore/engine/Abstraction/Matcher.ml +++ b/GillianCore/engine/Abstraction/Matcher.ml @@ -766,7 +766,7 @@ module Make (State : SState.S) : "@[-----------------@\n\ -----------------@\n\ Produce assertion: @[%a@]@]" Asrt.pp a); - let sas = MP.collect_simple_asrts a in + let sas = MP.simplify_asrts a in produce_asrt_list astate subst sas let produce_posts (state : t) (subst : SVal.SESubst.t) (asrts : Asrt.t list) : diff --git a/GillianCore/engine/Abstraction/PState.ml b/GillianCore/engine/Abstraction/PState.ml index 6a7dd8d7..ac0a1ce3 100644 --- a/GillianCore/engine/Abstraction/PState.ml +++ b/GillianCore/engine/Abstraction/PState.ml @@ -746,9 +746,7 @@ module Make (State : SState.S) : (SVal.SESubst.substitute_asrt subst_bindings ~partial:true a) in L.verbose (fun fmt -> fmt "Invariant v2: %a" Asrt.pp a_substed); - let a_produce = - Reduction.reduce_assertion (Asrt.star [ bindings; a_substed ]) - in + let a_produce = Reduction.reduce_assertion (bindings @ a_substed) in L.verbose (fun fmt -> fmt "Invariant v3: %a" Asrt.pp a_produce); (* Create empty state *) let invariant_state : t = clear_resource new_state in @@ -1018,7 +1016,7 @@ module Make (State : SState.S) : let a_substed = SVal.SESubst.substitute_asrt subst_bindings ~partial:true a in - let a_produce = Asrt.star [ a_new_bindings; a_substed ] in + let a_produce = a_new_bindings @ a_substed in let result = let** new_astate = SMatcher.produce new_state full_subst a_produce diff --git a/GillianCore/engine/BiAbduction/BiState.ml b/GillianCore/engine/BiAbduction/BiState.ml index 03345f20..3f68e243 100644 --- a/GillianCore/engine/BiAbduction/BiState.ml +++ b/GillianCore/engine/BiAbduction/BiState.ml @@ -193,12 +193,12 @@ module Make (State : SState.S) = struct in SVal.SESubst.init bindings - let fix_list_apply s = + let fix_list_apply (s : state_t) (asrt : Asrt.t) = let open Syntaxes.List in List.fold_left (fun acc a -> let* this_state = acc in - let lvars = Asrt.lvars a in + let lvars = Asrt.lvars [ a ] in let this_state = State.add_spec_vars this_state lvars in match a with | Asrt.Emp -> [ this_state ] @@ -217,7 +217,7 @@ module Make (State : SState.S) = struct State.produce_core_pred corepred this_state (ins @ outs) | Wand _ -> raise (Failure "DEATH. fix_list_apply wand") | Pred _ -> raise (Failure "DEATH. fix_list_apply pred")) - [ s ] + [ s ] asrt type post_res = (Flag.t * Asrt.t list) option diff --git a/GillianCore/engine/general_semantics/subst.ml b/GillianCore/engine/general_semantics/subst.ml index d03a84ea..2648715a 100644 --- a/GillianCore/engine/general_semantics/subst.ml +++ b/GillianCore/engine/general_semantics/subst.ml @@ -345,8 +345,8 @@ module Make (Val : Val.S) : S with type vt = Val.t = struct let is_empty (subst : t) : bool = Hashtbl.length subst = 0 - let substitute_formula (subst : t) ~(partial : bool) (a : Formula.t) : - Formula.t = + let substitute_formula (subst : t) ~(partial : bool) : Formula.t -> Formula.t + = let open Formula in let old_binders_substs = ref [] in let f_before a = @@ -376,25 +376,17 @@ module Make (Val : Val.S) : S with type vt = Val.t = struct a | _ -> a in - map (Some f_before) (Some f_after) (Some (subst_in_expr subst ~partial)) a + map (Some f_before) (Some f_after) (Some (subst_in_expr subst ~partial)) - let substitute_asrt (subst : t) ~(partial : bool) (a : Asrt.t) : Asrt.t = - Asrt.map None None - (Some (subst_in_expr subst ~partial)) - (Some (substitute_formula subst ~partial)) - a + let substitute_asrt (subst : t) ~(partial : bool) : Asrt.t -> Asrt.t = + Asrt.map (subst_in_expr subst ~partial) (substitute_formula subst ~partial) - let substitute_slcmd (subst : t) ~(partial : bool) (lcmd : SLCmd.t) : SLCmd.t - = - SLCmd.map None - (Some (substitute_asrt subst ~partial)) - (Some (subst_in_expr subst ~partial)) - lcmd - - let substitute_lcmd (subst : t) ~(partial : bool) (lcmd : LCmd.t) : LCmd.t = - LCmd.map None - (Some (subst_in_expr subst ~partial)) - (Some (substitute_formula subst ~partial)) - (Some (substitute_slcmd subst ~partial)) - lcmd + let substitute_slcmd (subst : t) ~(partial : bool) : SLCmd.t -> SLCmd.t = + SLCmd.map (substitute_asrt subst ~partial) (subst_in_expr subst ~partial) + + let substitute_lcmd (subst : t) ~(partial : bool) : LCmd.t -> LCmd.t = + LCmd.map + (subst_in_expr subst ~partial) + (substitute_formula subst ~partial) + (substitute_slcmd subst ~partial) end From 5c0f6d176650c71010923ad5f82032eb6c2ab0cd Mon Sep 17 00:00:00 2001 From: N1ark Date: Tue, 17 Sep 2024 18:33:24 +0100 Subject: [PATCH 06/54] Some cleaning --- Gillian-C/lib/gil_logic_gen.ml | 231 +++++++----------- GillianCore/GIL_Syntax/Gil_syntax.mli | 2 +- GillianCore/GIL_Syntax/Pred.ml | 4 +- .../engine/Abstraction/LogicPreprocessing.ml | 2 +- GillianCore/engine/Abstraction/Matcher.ml | 6 +- .../engine/symbolic_semantics/SState.ml | 2 +- 6 files changed, 102 insertions(+), 145 deletions(-) diff --git a/Gillian-C/lib/gil_logic_gen.ml b/Gillian-C/lib/gil_logic_gen.ml index 0133edc3..6593901e 100644 --- a/Gillian-C/lib/gil_logic_gen.ml +++ b/Gillian-C/lib/gil_logic_gen.ml @@ -134,85 +134,65 @@ let assert_of_member cenv members id typ = Fmt.failwith "Invalid member offset : %a@?" Driveraux.print_error e in (* The following bit of code should be refactored to be made cleaner ... *) - if - match typ with - | Tstruct _ -> true - | _ -> false - then - let struct_name, struct_id = - match typ with - | Tstruct (id, _) -> (true_name id, id) - | _ -> failwith "impossible" - in - let pred_name = pred_name_of_struct struct_name in - let arg_number = - List.length (Option.get (Maps.PTree.get struct_id cenv)).co_members - in - let args_without_ins = - List.init arg_number (fun k -> - Expr.LVar ("#i__" ^ field_name ^ "_" ^ string_of_int k)) - in - let list_is_components = - let open Formula.Infix in - Asrt.Pure pvmember #== (Expr.list args_without_ins) - in - let ofs = - let open Expr.Infix in - pvofs + fo - in - let args = pvloc :: ofs :: args_without_ins in - let pred_call = Asrt.Pred (pred_name, args) in - [ list_is_components; pred_call ] - else if - match typ with - | Tarray _ -> true - | _ -> false - then - let ty, n = - match typ with - | Tarray (ty, n, _) -> (ty, n) - | _ -> failwith "impossible" - in - let n = ValueTranslation.int_of_z n in - let n_e = Expr.int_z n in - let chunk = - match access_mode_by_value ty with - | Some chunk -> chunk - | _ -> failwith "Array in a structure containing complicated types" - in - [ - Constr.Core.array ~loc:pvloc ~ofs:(pvofs ++ fo) ~chunk ~size:n_e - ~sval_arr:pvmember ~perm:(Some Freeable); - ] - else - let mk t v = Expr.list [ Expr.string t; v ] in - let field_val_name = "#i__" ^ field_name ^ "_v" in - let lvval = Expr.LVar field_val_name in - let e_to_use, getter_or_type_pred = - let open Internal_Predicates in - let open VTypes in - match typ with - | Tint _ -> (mk int_type lvval, Asrt.Pred (int_get, [ pvmember; lvval ])) - | Tlong _ -> - (mk long_type lvval, Asrt.Pred (long_get, [ pvmember; lvval ])) - | Tfloat _ -> - (mk float_type lvval, Asrt.Pred (float_get, [ pvmember; lvval ])) - | Tpointer _ -> (pvmember, Asrt.Pred (is_ptr_opt, [ pvmember ])) - | _ -> - failwith - (Printf.sprintf "unhandled struct field type for now : %s" - (PrintCsyntax.name_cdecl field_name typ)) - in - let chunk = - match access_mode_by_value typ with - | Some chunk -> chunk - | _ -> failwith "Invalid access mode for some type" - in - let ga_asrt = - CoreP.single ~loc:pvloc ~ofs:(pvofs ++ fo) ~chunk ~sval:e_to_use - ~perm:(Some Freeable) - in - [ getter_or_type_pred; ga_asrt ] + match typ with + | Tstruct (struct_id, _) -> + let struct_name = true_name struct_id in + let pred_name = pred_name_of_struct struct_name in + let arg_number = + List.length (Option.get (Maps.PTree.get struct_id cenv)).co_members + in + let args_without_ins = + List.init arg_number (fun k -> + Expr.LVar ("#i__" ^ field_name ^ "_" ^ string_of_int k)) + in + let list_is_components = + Formula.Infix.(Asrt.Pure pvmember #== (Expr.list args_without_ins)) + in + let ofs = Expr.Infix.(pvofs + fo) in + let args = pvloc :: ofs :: args_without_ins in + let pred_call = Asrt.Pred (pred_name, args) in + [ list_is_components; pred_call ] + | Tarray (ty, n, _) -> + let n = ValueTranslation.int_of_z n in + let n_e = Expr.int_z n in + let chunk = + match access_mode_by_value ty with + | Some chunk -> chunk + | _ -> failwith "Array in a structure containing complicated types" + in + [ + Constr.Core.array ~loc:pvloc ~ofs:(pvofs ++ fo) ~chunk ~size:n_e + ~sval_arr:pvmember ~perm:(Some Freeable); + ] + | _ -> + let mk t v = Expr.list [ Expr.string t; v ] in + let field_val_name = "#i__" ^ field_name ^ "_v" in + let lvval = Expr.LVar field_val_name in + let e_to_use, getter_or_type_pred = + let open Internal_Predicates in + let open VTypes in + match typ with + | Tint _ -> (mk int_type lvval, Asrt.Pred (int_get, [ pvmember; lvval ])) + | Tlong _ -> + (mk long_type lvval, Asrt.Pred (long_get, [ pvmember; lvval ])) + | Tfloat _ -> + (mk float_type lvval, Asrt.Pred (float_get, [ pvmember; lvval ])) + | Tpointer _ -> (pvmember, Asrt.Pred (is_ptr_opt, [ pvmember ])) + | _ -> + failwith + (Printf.sprintf "unhandled struct field type for now : %s" + (PrintCsyntax.name_cdecl field_name typ)) + in + let chunk = + match access_mode_by_value typ with + | Some chunk -> chunk + | _ -> failwith "Invalid access mode for some type" + in + let ga_asrt = + CoreP.single ~loc:pvloc ~ofs:(pvofs ++ fo) ~chunk ~sval:e_to_use + ~perm:(Some Freeable) + in + [ getter_or_type_pred; ga_asrt ] let assert_of_hole (low, high) = let pvloc = Expr.PVar loc_param_name in @@ -245,22 +225,18 @@ let gen_pred_of_struct cenv ann struct_name = ] in let struct_params = - List.map - (function - | Member_plain (i, _) -> (true_name i, Some Type.ListType) - | Member_bitfield _ -> failwith "Unsupported bitfield members") - comp.co_members + comp.co_members + |> List.map @@ function + | Member_plain (i, _) -> (true_name i, Some Type.ListType) + | Member_bitfield _ -> failwith "Unsupported bitfield members" in let pred_params = first_params @ struct_params in let pred_num_params = List.length pred_params in let def_without_holes = - List.fold_left - (fun asrt member -> - match member with - | Member_plain (id, typ) -> - asrt @ assert_of_member cenv comp.co_members id typ - | Member_bitfield _ -> failwith "Unsupported bitfield members") - [] comp.co_members + comp.co_members + |> List.concat_map @@ function + | Member_plain (id, typ) -> assert_of_member cenv comp.co_members id typ + | Member_bitfield _ -> failwith "Unsupported bitfield members" in let fo idp = match field_offset cenv idp comp.co_members with @@ -402,7 +378,7 @@ let rec trans_expr (e : CExpr.t) : Asrt.t * Var.t list * Expr.t = | ptr -> let res_lvar = fresh_lvar () in let res = Expr.LVar res_lvar in - ( [ Constr.Others.ptr_add ~ptr ~to_add ~res ] @ a1 @ a2, + ( (Constr.Others.ptr_add ~ptr ~to_add ~res :: a1) @ a2, res_lvar :: (v1 @ v2), res )) | BinOp (e1, b, e2) -> @@ -524,50 +500,33 @@ let trans_constr ?fname:_ ~(typ : CAssert.points_to_type) ann s c = let mk str v = Expr.list [ Expr.string str; v ] in let mk_ptr l o = Expr.list [ l; o ] in match c with - | CConstructor.ConsExpr (SVal (Sint se)) -> - let e = cse se in - let chunk = Chunk.Mint32 in - let sv = mk int_type e in - let siz = sz (Sint se) in - let ga = - CoreP.single ~loc:locv ~ofs:ofsv ~chunk ~sval:sv ~perm:(Some Freeable) - in - [ ga; tint e; malloc_chunk siz ] @ to_assert - | ConsExpr (SVal (Sfloat se)) -> - let e = cse se in - let chunk = Chunk.Mfloat32 in - let siz = sz (Sfloat se) in - let sv = mk float_type e in - let ga = - CoreP.single ~loc:locv ~ofs:ofsv ~chunk ~sval:sv ~perm:(Some Freeable) - in - [ ga; tnum e; malloc_chunk siz ] @ to_assert - | ConsExpr (SVal (Ssingle se)) -> - let e = cse se in - let chunk = Chunk.Mfloat32 in - let siz = sz (Ssingle se) in - let sv = mk single_type e in - let ga = - CoreP.single ~loc:locv ~ofs:ofsv ~chunk ~sval:sv ~perm:(Some Freeable) + | CConstructor.ConsExpr (SVal (Sint v as se)) + | ConsExpr (SVal (Sfloat v as se)) + | ConsExpr (SVal (Ssingle v as se)) + | ConsExpr (SVal (Slong v as se)) -> + let chunk, typ, asrtfn = + match se with + | Sint _ -> (Chunk.Mint32, int_type, tint) + | Sfloat _ -> (Chunk.Mfloat32, float_type, tnum) + | Ssingle _ -> (Chunk.Mfloat32, single_type, tnum) + | Slong _ -> (Chunk.Mint64, long_type, tint) + | _ -> failwith "Impossible" in - [ ga; tnum e; malloc_chunk siz ] @ to_assert - | ConsExpr (SVal (Slong se)) -> - let e = cse se in - let chunk = Chunk.Mint64 in - let siz = sz (Slong se) in - let sv = mk long_type e in + let e = cse v in + let sval = mk typ e in + let siz = sz se in let ga = - CoreP.single ~loc:locv ~ofs:ofsv ~chunk ~sval:sv ~perm:(Some Freeable) + CoreP.single ~loc:locv ~ofs:ofsv ~chunk ~sval ~perm:(Some Freeable) in - [ ga; tint e; malloc_chunk siz ] @ to_assert + [ ga; asrtfn e; malloc_chunk siz ] @ to_assert | ConsExpr (SVal (Sptr (sl, so))) -> let l = cse sl in let o = cse so in let chunk = Chunk.ptr in let siz = sz (Sptr (sl, so)) in - let sv = mk_ptr l o in + let sval = mk_ptr l o in let ga = - CoreP.single ~loc:locv ~ofs:ofsv ~chunk ~sval:sv ~perm:(Some Freeable) + CoreP.single ~loc:locv ~ofs:ofsv ~chunk ~sval ~perm:(Some Freeable) in [ ga; tloc l; tint o; malloc_chunk siz ] @ to_assert | ConsExpr (SVal (Sfunptr fname)) -> @@ -682,16 +641,14 @@ let rec trans_lcmd ~fname ~ann lcmd = let trans_asrt_annot da = let { label; existentials } = da in let exs, typsb = - List.split - (List.map - (fun (ex, topt) -> - match topt with - | None -> (ex, Asrt.Emp) - | Some t -> (ex, types t (Expr.LVar ex))) - existentials) - in - let a = typsb in - (a, (label, exs)) + existentials + |> ( List.map @@ fun (ex, topt) -> + match topt with + | None -> (ex, Asrt.Emp) + | Some t -> (ex, types t (Expr.LVar ex)) ) + |> List.split + in + (typsb, (label, exs)) let trans_abs_pred ~filepath cl_pred = let CAbsPred. diff --git a/GillianCore/GIL_Syntax/Gil_syntax.mli b/GillianCore/GIL_Syntax/Gil_syntax.mli index 7d9b716e..4dbb6b89 100644 --- a/GillianCore/GIL_Syntax/Gil_syntax.mli +++ b/GillianCore/GIL_Syntax/Gil_syntax.mli @@ -823,7 +823,7 @@ module Pred : sig (** Given a guarded predicate, return a "call" to its close token. The arguments given are PVars with the same name as the ins of the predicate. *) - val close_token_call : t -> Asrt.t + val close_token_call : t -> Asrt.simple (** Given a name, if it's a close_token name, returns the name of the corresponding predicate, otherwise return None. *) diff --git a/GillianCore/GIL_Syntax/Pred.ml b/GillianCore/GIL_Syntax/Pred.ml index 4b62f345..f2d083b9 100644 --- a/GillianCore/GIL_Syntax/Pred.ml +++ b/GillianCore/GIL_Syntax/Pred.ml @@ -315,12 +315,12 @@ let close_token_name (pred : t) : string = failwith "close_token_name called on non-guarded predicate"; pred.pred_name ^ close_suffix -let close_token_call (pred : t) : Asrt.t = +let close_token_call (pred : t) : Asrt.simple = let name = close_token_name pred in let args = in_args pred pred.pred_params |> List.map (fun (x, _t) -> Expr.PVar x) in - [ Asrt.Pred (name, args) ] + Asrt.Pred (name, args) (* Given a name, if it's a close_token name, returns the name of the corresponding predicate, otherwise return None. *) diff --git a/GillianCore/engine/Abstraction/LogicPreprocessing.ml b/GillianCore/engine/Abstraction/LogicPreprocessing.ml index 56a465e0..a499b837 100644 --- a/GillianCore/engine/Abstraction/LogicPreprocessing.ml +++ b/GillianCore/engine/Abstraction/LogicPreprocessing.ml @@ -585,7 +585,7 @@ let add_closing_tokens preds = pred with pred_definitions = List.map - (fun (x, def) -> (x, def @ Pred.close_token_call pred)) + (fun (x, def) -> (x, Pred.close_token_call pred :: def)) pred.pred_definitions; }) |> Seq.iter (fun (pred : Pred.t) -> Hashtbl.replace preds pred.pred_name pred); diff --git a/GillianCore/engine/Abstraction/Matcher.ml b/GillianCore/engine/Abstraction/Matcher.ml index cd21b654..47260864 100644 --- a/GillianCore/engine/Abstraction/Matcher.ml +++ b/GillianCore/engine/Abstraction/Matcher.ml @@ -767,6 +767,7 @@ module Make (State : SState.S) : -----------------@\n\ Produce assertion: @[%a@]@]" Asrt.pp a); let sas = MP.simplify_asrts a in + L.verbose (fun m -> m "COLLECTED ATOMS: %a" Asrt.pp sas); produce_asrt_list astate subst sas let produce_posts (state : t) (subst : SVal.SESubst.t) (asrts : Asrt.t list) : @@ -1869,9 +1870,8 @@ module Make (State : SState.S) : let unfolded_pred = Hashtbl.find_opt LogicPreprocessing.unfolded_preds pred.pred_name in - match unfolded_pred with - | Some pred -> List.map snd pred.pred_definitions - | None -> List.map snd pred.pred_definitions + let pred = Option.value ~default:pred unfolded_pred in + List.map snd pred.pred_definitions let make_lhs_states ~pred_defs ~empty_state (lname, largs) = let open Syntaxes.List in diff --git a/GillianCore/engine/symbolic_semantics/SState.ml b/GillianCore/engine/symbolic_semantics/SState.ml index 2fa905f0..0dc1854e 100644 --- a/GillianCore/engine/symbolic_semantics/SState.ml +++ b/GillianCore/engine/symbolic_semantics/SState.ml @@ -747,7 +747,7 @@ module Make (SMemory : SMemory.S) : L.tmi (fun m -> m "All fixes before normalisation: %a" - Fmt.Dump.(list @@ Asrt.pp) + Fmt.Dump.(list Asrt.pp) one_step_fixes); List.map (fun fixes -> From 6cd169d846360b8be9cb56a82e47dbd47c7d512d Mon Sep 17 00:00:00 2001 From: N1ark Date: Tue, 17 Sep 2024 19:59:48 +0100 Subject: [PATCH 07/54] =?UTF-8?q?GILLIAN=20C=20!!!!!!!!!!=20=F0=9F=AB=B5?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- Gillian-C/lib/MonadicSMemory.ml | 2 +- Gillian-C/lib/MonadicSVal.ml | 6 ++++++ GillianCore/engine/Abstraction/Matcher.ml | 1 - 3 files changed, 7 insertions(+), 2 deletions(-) diff --git a/Gillian-C/lib/MonadicSMemory.ml b/Gillian-C/lib/MonadicSMemory.ml index 8cbb2d1a..7751222f 100644 --- a/Gillian-C/lib/MonadicSMemory.ml +++ b/Gillian-C/lib/MonadicSMemory.ml @@ -525,7 +525,7 @@ let execute_prod_single heap params = ] -> let perm = ValueTranslation.permission_of_string perm_string in let chunk = ValueTranslation.chunk_of_string chunk_string in - let* sval = SVal.of_gil_expr_exn sval_e in + let* sval = SVal.of_gil_expr_vanish sval_e in let++ mem = Mem.prod_single heap.mem loc ofs chunk sval perm in { heap with mem } | _ -> fail_ungracefully "set_single" params diff --git a/Gillian-C/lib/MonadicSVal.ml b/Gillian-C/lib/MonadicSVal.ml index 32d3bcf1..b38b73f0 100644 --- a/Gillian-C/lib/MonadicSVal.ml +++ b/Gillian-C/lib/MonadicSVal.ml @@ -119,6 +119,12 @@ let of_gil_expr_exn sval_e = if !Gillian.Utils.Config.under_approximation then Delayed.vanish () else raise (NotACompCertValue sval_e) +let of_gil_expr_vanish sval_e = + let* value_opt = of_gil_expr sval_e in + match value_opt with + | Some value -> Delayed.return value + | None -> Delayed.vanish () + let to_gil_expr_undelayed = to_gil_expr let to_gil_expr sval = diff --git a/GillianCore/engine/Abstraction/Matcher.ml b/GillianCore/engine/Abstraction/Matcher.ml index 47260864..f2b68b26 100644 --- a/GillianCore/engine/Abstraction/Matcher.ml +++ b/GillianCore/engine/Abstraction/Matcher.ml @@ -767,7 +767,6 @@ module Make (State : SState.S) : -----------------@\n\ Produce assertion: @[%a@]@]" Asrt.pp a); let sas = MP.simplify_asrts a in - L.verbose (fun m -> m "COLLECTED ATOMS: %a" Asrt.pp sas); produce_asrt_list astate subst sas let produce_posts (state : t) (subst : SVal.SESubst.t) (asrts : Asrt.t list) : From 4364169a88d2c25b27be448a0356d86f04152c3b Mon Sep 17 00:00:00 2001 From: N1ark Date: Tue, 17 Sep 2024 20:47:53 +0100 Subject: [PATCH 08/54] Gillian-C PLEASE --- Gillian-C/lib/MonadicSMemory.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/Gillian-C/lib/MonadicSMemory.ml b/Gillian-C/lib/MonadicSMemory.ml index 7751222f..4a665c2f 100644 --- a/Gillian-C/lib/MonadicSMemory.ml +++ b/Gillian-C/lib/MonadicSMemory.ml @@ -256,7 +256,7 @@ module Mem = struct let prod_bounds map loc bounds = let open DR.Syntax in - let** loc_name = resolve_loc_result loc in + let* loc_name = resolve_or_create_loc_name loc in let* tree = get_or_create_tree map loc_name in let++ tree_set = SHeapTree.prod_bounds tree bounds |> DR.of_result |> map_lift_err loc_name From d8f2731bae6b1a5c314ee7475131d81331dee015 Mon Sep 17 00:00:00 2001 From: N1ark Date: Tue, 17 Sep 2024 21:49:40 +0100 Subject: [PATCH 09/54] Remove extranuous emphs in gil gen --- Gillian-C/lib/gil_logic_gen.ml | 87 ++++++++++++----------- GillianCore/engine/Abstraction/Matcher.ml | 4 +- 2 files changed, 49 insertions(+), 42 deletions(-) diff --git a/Gillian-C/lib/gil_logic_gen.ml b/Gillian-C/lib/gil_logic_gen.ml index 6593901e..e50a5cfd 100644 --- a/Gillian-C/lib/gil_logic_gen.ml +++ b/Gillian-C/lib/gil_logic_gen.ml @@ -378,7 +378,7 @@ let rec trans_expr (e : CExpr.t) : Asrt.t * Var.t list * Expr.t = | ptr -> let res_lvar = fresh_lvar () in let res = Expr.LVar res_lvar in - ( (Constr.Others.ptr_add ~ptr ~to_add ~res :: a1) @ a2, + ( a1 @ a2 @ [ Constr.Others.ptr_add ~ptr ~to_add ~res ], res_lvar :: (v1 @ v2), res )) | BinOp (e1, b, e2) -> @@ -556,53 +556,58 @@ let trans_constr ?fname:_ ~(typ : CAssert.points_to_type) ann s c = let pr = Asrt.Pred (struct_pred, [ locv; ofsv ] @ params_fields) :: more_asrt in - [ malloc_chunk siz ] @ pr @ to_assert + pr @ to_assert @ [ malloc_chunk siz ] let rec trans_asrt ~fname ~ann asrt = - match asrt with - | CAssert.Star (a1, a2) -> - trans_asrt ~fname ~ann a1 @ trans_asrt ~fname ~ann a2 - | Array { ptr; chunk; size; content; malloced } -> - let a1, _, ptr = trans_expr ptr in - let a2, _, size = trans_expr size in - let a3, _, content = trans_expr content in - let malloc_p = - if malloced then - let open Expr.Infix in - let csize = Expr.int (Chunk.size chunk) in - let total_size = size * csize in - [ Constr.Others.malloced_abst ~ptr ~total_size ] - else [] - in - a1 @ a2 @ a3 - @ [ Constr.Others.array_ptr ~ptr ~chunk ~size ~content ] - @ malloc_p - | Malloced (e1, e2) -> - let a1, _, ce1 = trans_expr e1 in - let a2, _, ce2 = trans_expr e2 in - a1 @ a2 @ [ Constr.Others.malloced_abst ~ptr:ce1 ~total_size:ce2 ] - | Zeros (e1, e2) -> - let a1, _, ce1 = trans_expr e1 in - let a2, _, ce2 = trans_expr e2 in - a1 @ a2 @ [ Constr.Others.zeros_ptr_size ~ptr:ce1 ~size:ce2 ] - | Undefs (e1, e2) -> - let a1, _, ce1 = trans_expr e1 in - let a2, _, ce2 = trans_expr e2 in - a1 @ a2 @ [ Constr.Others.undefs_ptr_size ~ptr:ce1 ~size:ce2 ] - | Pure f -> - let ma, _, fp = trans_form f in - Pure fp :: ma - | Pred (p, cel) -> - let ap, _, gel = split3_expr_comp (List.map trans_expr cel) in - Pred (p, gel) :: ap - | Emp -> [ Asrt.Emp ] - | PointsTo { ptr = s; constr = c; typ } -> trans_constr ~fname ~typ ann s c + let a = + match asrt with + | CAssert.Star (a1, a2) -> + trans_asrt ~fname ~ann a1 @ trans_asrt ~fname ~ann a2 + | Array { ptr; chunk; size; content; malloced } -> + let a1, _, ptr = trans_expr ptr in + let a2, _, size = trans_expr size in + let a3, _, content = trans_expr content in + let malloc_p = + if malloced then + let open Expr.Infix in + let csize = Expr.int (Chunk.size chunk) in + let total_size = size * csize in + [ Constr.Others.malloced_abst ~ptr ~total_size ] + else [] + in + a1 @ a2 @ a3 + @ [ Constr.Others.array_ptr ~ptr ~chunk ~size ~content ] + @ malloc_p + | Malloced (e1, e2) -> + let a1, _, ce1 = trans_expr e1 in + let a2, _, ce2 = trans_expr e2 in + a1 @ a2 @ [ Constr.Others.malloced_abst ~ptr:ce1 ~total_size:ce2 ] + | Zeros (e1, e2) -> + let a1, _, ce1 = trans_expr e1 in + let a2, _, ce2 = trans_expr e2 in + a1 @ a2 @ [ Constr.Others.zeros_ptr_size ~ptr:ce1 ~size:ce2 ] + | Undefs (e1, e2) -> + let a1, _, ce1 = trans_expr e1 in + let a2, _, ce2 = trans_expr e2 in + a1 @ a2 @ [ Constr.Others.undefs_ptr_size ~ptr:ce1 ~size:ce2 ] + | Pure f -> + let ma, _, fp = trans_form f in + Pure fp :: ma + | Pred (p, cel) -> + let ap, _, gel = split3_expr_comp (List.map trans_expr cel) in + Pred (p, gel) :: ap + | Emp -> [ Asrt.Emp ] + | PointsTo { ptr = s; constr = c; typ } -> trans_constr ~fname ~typ ann s c + in + match List.filter (fun x -> x <> Asrt.Emp) a with + | [] -> [ Asrt.Emp ] + | a -> a let rec trans_lcmd ~fname ~ann lcmd = let trans_lcmd = trans_lcmd ~fname ~ann in let trans_asrt = trans_asrt ~fname ~ann in let make_assert ~bindings = function - | [] -> [] + | [] | [ Asrt.Emp ] -> [] | a -> [ LCmd.SL (SepAssert (a, bindings)) ] in match lcmd with diff --git a/GillianCore/engine/Abstraction/Matcher.ml b/GillianCore/engine/Abstraction/Matcher.ml index f2b68b26..73fad600 100644 --- a/GillianCore/engine/Abstraction/Matcher.ml +++ b/GillianCore/engine/Abstraction/Matcher.ml @@ -589,6 +589,9 @@ module Make (State : SState.S) : L.verbose (fun m -> m "STATE: %a" pp_astate astate); match (a : Asrt.simple) with + | Emp -> + L.verbose (fun fmt -> fmt "Emp assertion."); + [ Ok astate ] | CorePred (a_id, ins, outs) -> L.verbose (fun fmt -> fmt "Memory producer."); @@ -716,7 +719,6 @@ module Make (State : SState.S) : | Some state' -> Res_list.return { state = state'; preds; wands; pred_defs; variants }) - | _ -> L.fail "Produce simple assertion: unsupported assertion" and produce_asrt_list (astate : t) (subst : SVal.SESubst.t) (sas : Asrt.t) : (t, err_t) Res_list.t = From baa28c47b419c4e5e31da7af04ab9b0ea059f3bf Mon Sep 17 00:00:00 2001 From: N1ark Date: Thu, 10 Oct 2024 18:07:54 +0100 Subject: [PATCH 10/54] Cleanup --- GillianCore/engine/Abstraction/Matcher.ml | 15 +-------------- 1 file changed, 1 insertion(+), 14 deletions(-) diff --git a/GillianCore/engine/Abstraction/Matcher.ml b/GillianCore/engine/Abstraction/Matcher.ml index 73fad600..9a7c678c 100644 --- a/GillianCore/engine/Abstraction/Matcher.ml +++ b/GillianCore/engine/Abstraction/Matcher.ml @@ -960,26 +960,13 @@ module Make (State : SState.S) : | Some (pname, v_args) -> ( L.verbose (fun m -> m "FOUND STH TO UNFOLD: %s!!!!\n" pname); let rets = unfold (copy_astate astate) pname v_args in - let only_errors = - List.filter_map - (function - | Error e -> Some e - | _ -> None) - rets - in + let only_successes, only_errors = Res_list.split rets in match only_errors with | [] -> L.verbose (fun m -> m "Unfold complete: %s(@[%a@]): %d" pname Fmt.(list ~sep:comma Expr.pp) v_args (List.length rets)); - let only_successes = - List.filter_map - (function - | Ok x -> Some x - | _ -> None) - rets - in Some only_successes | _ :: _ -> L.verbose (fun m -> From c6c72d023a0f474b9639559411e83ee6c542127f Mon Sep 17 00:00:00 2001 From: N1ark Date: Wed, 11 Dec 2024 10:48:43 +0000 Subject: [PATCH 11/54] Fix stack overflow !! (oops) --- Gillian-JS/lib/Semantics/SHeap.ml | 2 +- GillianCore/GIL_Syntax/LCmd.ml | 5 +++-- 2 files changed, 4 insertions(+), 3 deletions(-) diff --git a/Gillian-JS/lib/Semantics/SHeap.ml b/Gillian-JS/lib/Semantics/SHeap.ml index 34edc0fb..f4a9885a 100644 --- a/Gillian-JS/lib/Semantics/SHeap.ml +++ b/Gillian-JS/lib/Semantics/SHeap.ml @@ -359,7 +359,7 @@ let assertions (heap : t) : Asrt.t = fv_assertions @ domain @ metadata in - List.sort Asrt.compare (List.concat_map assertions_of_object (to_list heap)) + to_list heap |> List.concat_map assertions_of_object |> List.sort Asrt.compare let wf_assertions_of_obj (heap : t) (loc : string) : Formula.t list = let cfvl = diff --git a/GillianCore/GIL_Syntax/LCmd.ml b/GillianCore/GIL_Syntax/LCmd.ml index fbcb53e4..f92a17a2 100644 --- a/GillianCore/GIL_Syntax/LCmd.ml +++ b/GillianCore/GIL_Syntax/LCmd.ml @@ -16,9 +16,10 @@ type t = TypeDef__.lcmd = let rec map (f_e : Expr.t -> Expr.t) (f_p : Formula.t -> Formula.t) - (f_sl : SLCmd.t -> SLCmd.t) = + (f_sl : SLCmd.t -> SLCmd.t) + (lcmd : t) = let f = map f_e f_p f_sl in - function + match lcmd with | Branch a -> Branch (f_p a) | If (e, l1, l2) -> If (f_e e, List.map f l1, List.map f l2) | Macro (s, l) -> Macro (s, List.map f_e l) From c6a7574c874dc503608eb81ba8c4d4396b100248 Mon Sep 17 00:00:00 2001 From: N1ark Date: Wed, 11 Dec 2024 11:05:29 +0000 Subject: [PATCH 12/54] Rename `Asrt.simple` to `Asrt.atom` --- GillianCore/GIL_Syntax/Asrt.ml | 18 ++--- GillianCore/GIL_Syntax/Gil_syntax.mli | 66 ++++++++----------- GillianCore/GIL_Syntax/Pred.ml | 2 +- GillianCore/GIL_Syntax/TypeDef__.ml | 4 +- GillianCore/debugging/utils/match_map.ml | 2 +- .../engine/Abstraction/LogicPreprocessing.ml | 2 +- GillianCore/engine/Abstraction/MP.ml | 24 +++---- GillianCore/engine/Abstraction/MP.mli | 2 +- GillianCore/engine/Abstraction/Matcher.ml | 16 ++--- GillianCore/engine/Abstraction/Matcher.mli | 2 +- GillianCore/engine/Abstraction/Normaliser.ml | 6 +- GillianCore/engine/Abstraction/Preds.ml | 2 +- GillianCore/engine/BiAbduction/BiState.ml | 2 +- GillianCore/engine/FOLogic/Reduction.ml | 2 +- GillianCore/engine/FOLogic/Simplifications.ml | 2 +- 15 files changed, 72 insertions(+), 80 deletions(-) diff --git a/GillianCore/GIL_Syntax/Asrt.ml b/GillianCore/GIL_Syntax/Asrt.ml index c8dc67f7..ed3cece0 100644 --- a/GillianCore/GIL_Syntax/Asrt.ml +++ b/GillianCore/GIL_Syntax/Asrt.ml @@ -1,5 +1,5 @@ (** {b GIL logic assertions}. *) -type simple = TypeDef__.assertion_simple = +type atom = TypeDef__.assertion_atom = | Emp (** Empty heap *) | Pred of string * Expr.t list (** Predicates *) | Pure of Formula.t (** Pure formula *) @@ -12,8 +12,8 @@ type simple = TypeDef__.assertion_simple = type t = TypeDef__.assertion [@@deriving eq] -let simple_to_yojson = TypeDef__.assertion_simple_to_yojson -let simple_of_yojson = TypeDef__.assertion_simple_of_yojson +let atom_to_yojson = TypeDef__.assertion_atom_to_yojson +let atom_of_yojson = TypeDef__.assertion_atom_of_yojson let to_yojson = TypeDef__.assertion_to_yojson let of_yojson = TypeDef__.assertion_of_yojson @@ -31,7 +31,7 @@ let compare x y = | _, Types _ -> 1 | _, _ -> cmp x y -let prioritise (a1 : simple) (a2 : simple) = +let prioritise (a1 : atom) (a2 : atom) = let lloc_aloc_pvar_lvar e1 e2 = match ((e1 : Expr.t), (e2 : Expr.t)) with | Lit (Loc _), Lit (Loc _) -> 0 @@ -127,7 +127,7 @@ let pure_asrts : t -> Formula.t list = collector#visit_assertion () (* Check if --a-- is a pure assertion *) -let is_pure_asrt : simple -> bool = function +let is_pure_asrt : atom -> bool = function | Pred _ | CorePred _ | Wand _ -> false | _ -> true @@ -143,7 +143,7 @@ let make_pure (a : t) : Formula.t = |> Formula.conjunct (** GIL logic assertions *) -let _pp_simple ?(e_pp : Format.formatter -> Expr.t -> unit = Expr.pp) fmt = +let _pp_atom ?(e_pp : Format.formatter -> Expr.t -> unit = Expr.pp) fmt = function | Emp -> Fmt.string fmt "emp" | Pred (name, params) -> @@ -167,10 +167,10 @@ let _pp_simple ?(e_pp : Format.formatter -> Expr.t -> unit = Expr.pp) fmt = let _pp ~(e_pp : Format.formatter -> Expr.t -> unit) (fmt : Format.formatter) : t -> unit = - Fmt.list ~sep:(Fmt.any " *@ ") (_pp_simple ~e_pp) fmt + Fmt.list ~sep:(Fmt.any " *@ ") (_pp_atom ~e_pp) fmt -let pp_simple = _pp_simple ~e_pp:Expr.pp -let pp_simple_full = _pp_simple ~e_pp:Expr.full_pp +let pp_atom = _pp_atom ~e_pp:Expr.pp +let pp_atom_full = _pp_atom ~e_pp:Expr.full_pp let pp = _pp ~e_pp:Expr.pp let full_pp = _pp ~e_pp:Expr.full_pp diff --git a/GillianCore/GIL_Syntax/Gil_syntax.mli b/GillianCore/GIL_Syntax/Gil_syntax.mli index 4dbb6b89..35ea8484 100644 --- a/GillianCore/GIL_Syntax/Gil_syntax.mli +++ b/GillianCore/GIL_Syntax/Gil_syntax.mli @@ -563,7 +563,7 @@ end module Asrt : sig (** GIL Assertions *) - type simple = + type atom = | Emp (** Empty heap *) | Pred of string * Expr.t list (** Predicates *) | Pure of Formula.t (** Pure formula *) @@ -573,13 +573,13 @@ module Asrt : sig (** Magic wand of the form [P(...) -* Q(...)] *) [@@deriving yojson, eq] - type t = simple list [@@deriving yojson, eq] + type t = atom list [@@deriving yojson, eq] (** Comparison of assertions *) - val compare : simple -> simple -> int + val compare : atom -> atom -> int (** Sorting of assertions *) - val prioritise : simple -> simple -> int + val prioritise : atom -> atom -> int (** Sets of assertions *) module Set : Set.S with type elt := t @@ -613,7 +613,7 @@ module Asrt : sig val pure_asrts : t -> Formula.t list (** Check if [a] is a pure assertion *) - val is_pure_asrt : simple -> bool + val is_pure_asrt : atom -> bool (** Eliminate LStar and LTypes assertions. LTypes disappears. LStar is replaced by LAnd. @@ -623,12 +623,12 @@ module Asrt : sig (** Pretty-printer *) val pp : Format.formatter -> t -> unit - val pp_simple : Format.formatter -> simple -> unit + val pp_atom : Format.formatter -> atom -> unit (** Full pretty-printer *) val full_pp : Format.formatter -> t -> unit - val pp_simple_full : Format.formatter -> simple -> unit + val pp_atom_full : Format.formatter -> atom -> unit (** [subst_clocs subst a] Substitutes expressions of the form [Lit (Loc l)] with [subst l] in [a] *) val subst_clocs : (string -> Expr.t) -> t -> t @@ -823,7 +823,7 @@ module Pred : sig (** Given a guarded predicate, return a "call" to its close token. The arguments given are PVars with the same name as the ins of the predicate. *) - val close_token_call : t -> Asrt.simple + val close_token_call : t -> Asrt.atom (** Given a name, if it's a close_token name, returns the name of the corresponding predicate, otherwise return None. *) @@ -1300,7 +1300,7 @@ module Visitors : sig 'c -> Expr.t -> (string * Type.t option) list -> Expr.t -> Expr.t ; visit_EForall : 'c -> Expr.t -> (string * Type.t option) list -> Expr.t -> Expr.t - ; visit_Emp : 'c -> Asrt.simple -> Asrt.simple + ; visit_Emp : 'c -> Asrt.atom -> Asrt.atom ; visit_Empty : 'c -> Literal.t -> Literal.t ; visit_EmptyType : 'c -> Type.t -> Type.t ; visit_Epsilon : 'c -> Constant.t -> Constant.t @@ -1332,17 +1332,17 @@ module Visitors : sig Formula.t ; visit_CorePred : 'c -> - Asrt.simple -> + Asrt.atom -> string -> Expr.t list -> Expr.t list -> - Asrt.simple + Asrt.atom ; visit_Wand : 'c -> - Asrt.simple -> + Asrt.atom -> string * Expr.t list -> string * Expr.t list -> - Asrt.simple + Asrt.atom ; visit_GUnfold : 'c -> SLCmd.t -> string -> SLCmd.t ; visit_Goto : 'c -> 'f Cmd.t -> 'f -> 'f Cmd.t ; visit_GuardedGoto : 'c -> 'f Cmd.t -> Expr.t -> 'f -> 'f -> 'f Cmd.t @@ -1420,9 +1420,8 @@ module Visitors : sig ; visit_PhiAssignment : 'c -> 'f Cmd.t -> (string * Expr.t list) list -> 'f Cmd.t ; visit_Pi : 'c -> Constant.t -> Constant.t - ; visit_Pred : - 'c -> Asrt.simple -> string -> Expr.t list -> Asrt.simple - ; visit_Pure : 'c -> Asrt.simple -> Formula.t -> Asrt.simple + ; visit_Pred : 'c -> Asrt.atom -> string -> Expr.t list -> Asrt.atom + ; visit_Pure : 'c -> Asrt.atom -> Formula.t -> Asrt.atom ; visit_Random : 'c -> Constant.t -> Constant.t ; visit_ReturnError : 'c -> 'f Cmd.t -> 'f Cmd.t ; visit_ReturnNormal : 'c -> 'f Cmd.t -> 'f Cmd.t @@ -1460,8 +1459,7 @@ module Visitors : sig ; visit_Type : 'c -> Literal.t -> Type.t -> Literal.t ; visit_TypeOf : 'c -> UnOp.t -> UnOp.t ; visit_TypeType : 'c -> Type.t -> Type.t - ; visit_Types : - 'c -> Asrt.simple -> (Expr.t * Type.t) list -> Asrt.simple + ; visit_Types : 'c -> Asrt.atom -> (Expr.t * Type.t) list -> Asrt.atom ; visit_UNot : 'c -> UnOp.t -> UnOp.t ; visit_UTCTime : 'c -> Constant.t -> Constant.t ; visit_UnOp : 'c -> Expr.t -> UnOp.t -> Expr.t -> Expr.t @@ -1484,7 +1482,7 @@ module Visitors : sig ; visit_UnsignedRightShift : 'c -> BinOp.t -> BinOp.t ; visit_UnsignedRightShiftL : 'c -> BinOp.t -> BinOp.t ; visit_UnsignedRightShiftF : 'c -> BinOp.t -> BinOp.t - ; visit_assertion_simple : 'c -> Asrt.simple -> Asrt.simple + ; visit_assertion_atom : 'c -> Asrt.atom -> Asrt.atom ; visit_assertion : 'c -> Asrt.t -> Asrt.t ; visit_bindings : 'c -> @@ -1576,7 +1574,7 @@ module Visitors : sig method visit_EForall : 'c -> Expr.t -> (string * Type.t option) list -> Expr.t -> Expr.t - method visit_Emp : 'c -> Asrt.simple -> Asrt.simple + method visit_Emp : 'c -> Asrt.atom -> Asrt.atom method visit_Empty : 'c -> Literal.t -> Literal.t method visit_EmptyType : 'c -> Type.t -> Type.t method visit_Epsilon : 'c -> Constant.t -> Constant.t @@ -1606,14 +1604,14 @@ module Visitors : sig 'c -> Formula.t -> (string * Type.t option) list -> Formula.t -> Formula.t method visit_CorePred : - 'c -> Asrt.simple -> string -> Expr.t list -> Expr.t list -> Asrt.simple + 'c -> Asrt.atom -> string -> Expr.t list -> Expr.t list -> Asrt.atom method visit_Wand : 'c -> - Asrt.simple -> + Asrt.atom -> string * Expr.t list -> string * Expr.t list -> - Asrt.simple + Asrt.atom method visit_GUnfold : 'c -> SLCmd.t -> string -> SLCmd.t method visit_Goto : 'c -> 'f Cmd.t -> 'f -> 'f Cmd.t @@ -1698,11 +1696,8 @@ module Visitors : sig 'c -> 'f Cmd.t -> (string * Expr.t list) list -> 'f Cmd.t method visit_Pi : 'c -> Constant.t -> Constant.t - - method visit_Pred : - 'c -> Asrt.simple -> string -> Expr.t list -> Asrt.simple - - method visit_Pure : 'c -> Asrt.simple -> Formula.t -> Asrt.simple + method visit_Pred : 'c -> Asrt.atom -> string -> Expr.t list -> Asrt.atom + method visit_Pure : 'c -> Asrt.atom -> Formula.t -> Asrt.atom method visit_Random : 'c -> Constant.t -> Constant.t method visit_ReturnError : 'c -> 'f Cmd.t -> 'f Cmd.t method visit_ReturnNormal : 'c -> 'f Cmd.t -> 'f Cmd.t @@ -1740,10 +1735,7 @@ module Visitors : sig method visit_Type : 'c -> Literal.t -> Type.t -> Literal.t method visit_TypeOf : 'c -> UnOp.t -> UnOp.t method visit_TypeType : 'c -> Type.t -> Type.t - - method visit_Types : - 'c -> Asrt.simple -> (Expr.t * Type.t) list -> Asrt.simple - + method visit_Types : 'c -> Asrt.atom -> (Expr.t * Type.t) list -> Asrt.atom method visit_UNot : 'c -> UnOp.t -> UnOp.t method visit_UTCTime : 'c -> Constant.t -> Constant.t method visit_UnOp : 'c -> Expr.t -> UnOp.t -> Expr.t -> Expr.t @@ -1769,7 +1761,7 @@ module Visitors : sig method private visit_array : 'env 'a. ('env -> 'a -> 'a) -> 'env -> 'a array -> 'a array - method visit_assertion_simple : 'c -> Asrt.simple -> Asrt.simple + method visit_assertion_atom : 'c -> Asrt.atom -> Asrt.atom method visit_assertion : 'c -> Asrt.t -> Asrt.t method visit_bindings : @@ -2039,7 +2031,7 @@ module Visitors : sig ; visit_UnsignedRightShift : 'c -> 'f ; visit_UnsignedRightShiftL : 'c -> 'f ; visit_UnsignedRightShiftF : 'c -> 'f - ; visit_assertion_simple : 'c -> Asrt.simple -> 'f + ; visit_assertion_atom : 'c -> Asrt.atom -> 'f ; visit_assertion : 'c -> Asrt.t -> 'f ; visit_bindings : 'c -> string * (string * Expr.t) list -> 'f ; visit_binop : 'c -> BinOp.t -> 'f @@ -2275,7 +2267,7 @@ module Visitors : sig method visit_UnsignedRightShift : 'c -> 'f method visit_UnsignedRightShiftL : 'c -> 'f method visit_UnsignedRightShiftF : 'c -> 'f - method visit_assertion_simple : 'c -> Asrt.simple -> 'f + method visit_assertion_atom : 'c -> Asrt.atom -> 'f method visit_assertion : 'c -> Asrt.t -> 'f method visit_bindings : 'c -> string * (string * Expr.t) list -> 'f method visit_binop : 'c -> BinOp.t -> 'f @@ -2511,7 +2503,7 @@ module Visitors : sig ; visit_UnsignedRightShift : 'c -> unit ; visit_UnsignedRightShiftL : 'c -> unit ; visit_UnsignedRightShiftF : 'c -> unit - ; visit_assertion_simple : 'c -> Asrt.simple -> unit + ; visit_assertion_atom : 'c -> Asrt.atom -> unit ; visit_assertion : 'c -> Asrt.t -> unit ; visit_bindings : 'c -> string * (string * Expr.t) list -> unit ; visit_binop : 'c -> BinOp.t -> unit @@ -2760,7 +2752,7 @@ module Visitors : sig method private visit_array : 'env 'a. ('env -> 'a -> unit) -> 'env -> 'a array -> unit - method visit_assertion_simple : 'c -> Asrt.simple -> unit + method visit_assertion_atom : 'c -> Asrt.atom -> unit method visit_assertion : 'c -> Asrt.t -> unit method visit_bindings : 'c -> string * (string * Expr.t) list -> unit method visit_binop : 'c -> BinOp.t -> unit diff --git a/GillianCore/GIL_Syntax/Pred.ml b/GillianCore/GIL_Syntax/Pred.ml index f2d083b9..a8230fa3 100644 --- a/GillianCore/GIL_Syntax/Pred.ml +++ b/GillianCore/GIL_Syntax/Pred.ml @@ -315,7 +315,7 @@ let close_token_name (pred : t) : string = failwith "close_token_name called on non-guarded predicate"; pred.pred_name ^ close_suffix -let close_token_call (pred : t) : Asrt.simple = +let close_token_call (pred : t) : Asrt.atom = let name = close_token_name pred in let args = in_args pred pred.pred_params |> List.map (fun (x, _t) -> Expr.PVar x) diff --git a/GillianCore/GIL_Syntax/TypeDef__.ml b/GillianCore/GIL_Syntax/TypeDef__.ml index 49473e46..1f53f52b 100644 --- a/GillianCore/GIL_Syntax/TypeDef__.ml +++ b/GillianCore/GIL_Syntax/TypeDef__.ml @@ -162,7 +162,7 @@ and formula = | ForAll of (string * typ option) list * formula | IsInt of expr -and assertion_simple = +and assertion_atom = | Emp | Pred of string * expr list | Pure of formula @@ -170,7 +170,7 @@ and assertion_simple = | CorePred of string * expr list * expr list | Wand of { lhs : string * expr list; rhs : string * expr list } -and assertion = assertion_simple list +and assertion = assertion_atom list and bindings = string * (string * expr) list and slcmd = diff --git a/GillianCore/debugging/utils/match_map.ml b/GillianCore/debugging/utils/match_map.ml index 364c1957..974574bb 100644 --- a/GillianCore/debugging/utils/match_map.ml +++ b/GillianCore/debugging/utils/match_map.ml @@ -63,7 +63,7 @@ functor in let assertion = let asrt, _ = asrt_report.step in - Fmt.str "%a" Asrt.pp_simple asrt + Fmt.str "%a" Asrt.pp_atom asrt in let substitutions = asrt_report.subst |> Subst.to_list_pp diff --git a/GillianCore/engine/Abstraction/LogicPreprocessing.ml b/GillianCore/engine/Abstraction/LogicPreprocessing.ml index a499b837..71784fd4 100644 --- a/GillianCore/engine/Abstraction/LogicPreprocessing.ml +++ b/GillianCore/engine/Abstraction/LogicPreprocessing.ml @@ -49,7 +49,7 @@ let rec auto_unfold | Pred (name, args) -> ( try L.tmi (fun fmt -> - fmt "AutoUnfold: %a : %s" Asrt.pp_simple asrt name); + fmt "AutoUnfold: %a : %s" Asrt.pp_atom asrt name); let pred : Pred.t = Hashtbl.find predicates name in (* If it is not, replace the predicate assertion for the list of its definitions substituting the formal parameters of the predicate with the corresponding diff --git a/GillianCore/engine/Abstraction/MP.ml b/GillianCore/engine/Abstraction/MP.ml index 8b8ee5c0..1bb62b13 100644 --- a/GillianCore/engine/Abstraction/MP.ml +++ b/GillianCore/engine/Abstraction/MP.ml @@ -12,9 +12,9 @@ let outs_pp = (** The [mp_step] type represents a matching plan step, consisting of an assertion together with the possible learned outs *) -type step = Asrt.simple * outs [@@deriving yojson, eq] +type step = Asrt.atom * outs [@@deriving yojson, eq] -let pp_step = Fmt.pair ~sep:(Fmt.any ", ") Asrt.pp_simple_full outs_pp +let pp_step = Fmt.pair ~sep:(Fmt.any ", ") Asrt.pp_atom_full outs_pp let pp_step_list = Fmt.Dump.list pp_step type label = string * SS.t [@@deriving eq, yojson] @@ -499,13 +499,14 @@ let ins_outs_formula (kb : KB.t) (pf : Formula.t) : (KB.t * outs) list = let ins_outs_assertion (pred_ins : (string, int list) Hashtbl.t) (kb : KB.t) - (asrt : Asrt.simple) : (KB.t * outs) list = + (asrt : Asrt.atom) : (KB.t * outs) list = let get_pred_ins name = match Hashtbl.find_opt pred_ins name with | None -> raise (Failure ("ins_outs_assertion. Unknown Predicate: " ^ name)) | Some ins -> ins in - match (asrt : Asrt.simple) with + match (asrt : Asrt.atom) with + | Emp -> [] | Pure form -> ins_outs_formula kb form | CorePred (_, lie, loe) -> ins_and_outs_from_lists kb lie loe | Pred (p_name, args) -> @@ -522,6 +523,7 @@ let ins_outs_assertion | Types [ (e, _) ] -> let ins = simple_ins_expr e in List.map (fun ins -> (ins, [])) ins + | Types _ -> failwith "Impossible: non-atomic types assertion in get_pred_ins" | Wand { lhs = _, largs; rhs = rname, rargs } -> let r_ins = get_pred_ins rname in let _, llie, lloe = @@ -532,11 +534,9 @@ let ins_outs_assertion (0, [], []) rargs in ins_and_outs_from_lists kb (largs @ List.rev llie) lloe - | _ -> - raise (Failure "Impossible: non-simple assertion in ins_outs_assertion.") let simplify_asrts a = - let rec aux (a : Asrt.simple) : Asrt.simple list = + let rec aux (a : Asrt.atom) : Asrt.atom list = match a with | Pure True | Emp -> [] | Pure (And (f1, f2)) -> aux (Pure f1) @ aux (Pure f2) @@ -564,7 +564,7 @@ let s_init_atoms ~preds kb atoms = L.verbose (fun m -> m "KNOWN: @[%a@].@\n@[CUR MP:@\n%a@]@\nTO VISIT: @[%a@]" kb_pp kb pp_step_list current - (Fmt.list ~sep:(Fmt.any "@\n") Asrt.pp_simple_full) + (Fmt.list ~sep:(Fmt.any "@\n") Asrt.pp_atom_full) rest); match rest with | [] -> @@ -648,7 +648,7 @@ let init (preds : (string, int list) Hashtbl.t) (asrts_posts : (Asrt.t * ((string * SS.t) option * (Flag.t * Asrt.t list) option)) list) - : (t, Asrt.simple list list) result = + : (t, Asrt.atom list list) result = let known_matchables = match use_params with | None -> known_matchables @@ -902,7 +902,7 @@ let pp_asrt ~(preds : preds_tbl_t) (fmt : Format.formatter) (a : Asrt.t) = - let pp_simple_asrt fmt = function + let pp_atom_asrt fmt = function | Asrt.Pred (name, args) -> ( match preds_printer with | Some pp_pred -> (Fmt.hbox pp_pred) fmt (name, args) @@ -920,9 +920,9 @@ let pp_asrt (Pred.pp_ins_outs pred.pred Expr.pp pp_out_params_args) (in_args, out_params_args) with _ -> Asrt.pp fmt a)) - | a -> Asrt.pp_simple fmt a + | a -> Asrt.pp_atom fmt a in - Fmt.list ~sep:(Fmt.any " *@ ") pp_simple_asrt fmt a + Fmt.list ~sep:(Fmt.any " *@ ") pp_atom_asrt fmt a let pp_sspec ?(preds_printer : (Format.formatter -> string * Expr.t list -> unit) option) diff --git a/GillianCore/engine/Abstraction/MP.mli b/GillianCore/engine/Abstraction/MP.mli index df54af13..b36c27c1 100644 --- a/GillianCore/engine/Abstraction/MP.mli +++ b/GillianCore/engine/Abstraction/MP.mli @@ -7,7 +7,7 @@ val outs_pp : outs Fmt.t (** The [step] type represents a matching plan step, consisting of an assertion together with the possible learned outs *) -type step = Asrt.simple * outs [@@deriving yojson] +type step = Asrt.atom * outs [@@deriving yojson] type label = string * SS.t [@@deriving yojson] type post = Flag.t * Asrt.t list [@@deriving yojson] diff --git a/GillianCore/engine/Abstraction/Matcher.ml b/GillianCore/engine/Abstraction/Matcher.ml index 9a7c678c..d3b9c57c 100644 --- a/GillianCore/engine/Abstraction/Matcher.ml +++ b/GillianCore/engine/Abstraction/Matcher.ml @@ -77,7 +77,7 @@ module type S = sig type unfold_info_t = (string * string) list val produce_assertion : - t -> SVal.SESubst.t -> Asrt.simple -> (t, err_t) Res_list.t + t -> SVal.SESubst.t -> Asrt.atom -> (t, err_t) Res_list.t val produce : t -> SVal.SESubst.t -> Asrt.t -> (t, err_t) Res_list.t val produce_posts : t -> SVal.SESubst.t -> Asrt.t list -> t list @@ -573,7 +573,7 @@ module Make (State : SState.S) : let rec produce_assertion (astate : t) (subst : SVal.SESubst.t) - (a : Asrt.simple) : (t, err_t) Res_list.t = + (a : Asrt.atom) : (t, err_t) Res_list.t = let open Res_list.Syntax in let { state; preds; pred_defs; variants; wands } = astate in let other_state_err msg = [ Error (StateErr.EOther msg) ] in @@ -584,11 +584,11 @@ module Make (State : SState.S) : Produce simple assertion: @[%a@]@\n\ With subst: %a\n\ \ -------------------------@\n" - Asrt.pp_simple a SVal.SESubst.pp subst); + Asrt.pp_atom a SVal.SESubst.pp subst); L.verbose (fun m -> m "STATE: %a" pp_astate astate); - match (a : Asrt.simple) with + match (a : Asrt.atom) with | Emp -> L.verbose (fun fmt -> fmt "Emp assertion."); [ Ok astate ] @@ -1260,12 +1260,12 @@ module Make (State : SState.S) : L.Logging_constants.Content_type.assertion (fun () -> let p, outs = step in let open Res_list.Syntax in - match (p : Asrt.simple) with + match (p : Asrt.atom) with | CorePred (a_id, e_ins, e_outs) -> ( let vs_ins = List.map (subst_in_expr_opt astate subst) e_ins in let failure = List.exists (fun x -> x = None) vs_ins in if failure then ( - Fmt.pr "I don't know all ins for %a????" Asrt.pp_simple p; + Fmt.pr "I don't know all ins for %a????" Asrt.pp_atom p; if !Config.under_approximation then [] else resource_fail) else let vs_ins = List.map Option.get vs_ins in @@ -1454,7 +1454,7 @@ module Make (State : SState.S) : let other_error = StateErr.EOther (Fmt.str "Uncaught exception while matching assertions %a" - Asrt.pp_simple (fst step)) + Asrt.pp_atom (fst step)) in Res_list.error_with other_error) @@ -2086,7 +2086,7 @@ module Make (State : SState.S) : (step : MP.step) : (package_state list, err_t list) Result.t = let open Syntaxes.Result in L.verbose (fun m -> - m "Wand about to consume RHS step: %a" Asrt.pp_simple (fst step)); + m "Wand about to consume RHS step: %a" Asrt.pp_atom (fst step)); (* States are modified in place unfortunately.. so we have to copy them just in case *) (* First we try to consume from the lhs_state *) let- lhs_errs = diff --git a/GillianCore/engine/Abstraction/Matcher.mli b/GillianCore/engine/Abstraction/Matcher.mli index d82ae684..c3a30986 100644 --- a/GillianCore/engine/Abstraction/Matcher.mli +++ b/GillianCore/engine/Abstraction/Matcher.mli @@ -77,7 +77,7 @@ module type S = sig type unfold_info_t = (string * string) list val produce_assertion : - t -> SVal.SESubst.t -> Asrt.simple -> (t, err_t) Res_list.t + t -> SVal.SESubst.t -> Asrt.atom -> (t, err_t) Res_list.t val produce : t -> SVal.SESubst.t -> Asrt.t -> (t, err_t) Res_list.t val produce_posts : t -> SVal.SESubst.t -> Asrt.t list -> t list diff --git a/GillianCore/engine/Abstraction/Normaliser.ml b/GillianCore/engine/Abstraction/Normaliser.ml index 46a64d99..78d8d890 100644 --- a/GillianCore/engine/Abstraction/Normaliser.ml +++ b/GillianCore/engine/Abstraction/Normaliser.ml @@ -561,7 +561,7 @@ module Make (SPState : PState.S) = struct * (string * Expr.t list) list * Wands.wand list = List.fold_left - (fun (core_asrts, pure, types, preds, wands) (a : Asrt.simple) -> + (fun (core_asrts, pure, types, preds, wands) (a : Asrt.atom) -> match a with | CorePred (a, es1, es2) -> ((a, es1, es2) :: core_asrts, pure, types, preds, wands) @@ -842,7 +842,7 @@ module Make (SPState : PState.S) = struct m "One branch of produce GA failed for: %a!\n\ with Message: %a. Might have lost some paths ?" - Asrt.pp_simple + Asrt.pp_atom (Asrt.CorePred (a, ins, outs)) SPState.pp_err msg); None)) @@ -873,7 +873,7 @@ module Make (SPState : PState.S) = struct let a = Reduction.reduce_assertion a in let subst = SESubst.init [] in - let find_spec_var_eqs (a : Asrt.simple) = + let find_spec_var_eqs (a : Asrt.atom) = match a with | Pure (Eq (LVar x, LVar y)) when is_spec_var_name x && not (is_spec_var_name y) -> diff --git a/GillianCore/engine/Abstraction/Preds.ml b/GillianCore/engine/Abstraction/Preds.ml index 46d6d950..7d0010ad 100644 --- a/GillianCore/engine/Abstraction/Preds.ml +++ b/GillianCore/engine/Abstraction/Preds.ml @@ -223,7 +223,7 @@ let substitution_in_place (subst : st) (preds : t) : unit = let pred_substitution subst (s, vs) = (s, List.map (subst_in_val subst) vs) in preds := List.map (pred_substitution subst) !preds -let to_assertions (preds : t) : Asrt.simple list = +let to_assertions (preds : t) : Asrt.atom list = let preds = to_list preds in let pred_to_assert (n, args) = Asrt.Pred (n, args) in List.sort Asrt.compare (List.map pred_to_assert preds) diff --git a/GillianCore/engine/BiAbduction/BiState.ml b/GillianCore/engine/BiAbduction/BiState.ml index 3f68e243..ce3268f0 100644 --- a/GillianCore/engine/BiAbduction/BiState.ml +++ b/GillianCore/engine/BiAbduction/BiState.ml @@ -257,7 +257,7 @@ module Make (State : SState.S) = struct "@[WARNING: Match Assertion Failed: %a with error: \ %a. CUR SUBST:@\n\ %a@]@\n" - Asrt.pp_simple (fst step) State.pp_err err SVal.SESubst.pp + Asrt.pp_atom (fst step) State.pp_err err SVal.SESubst.pp subst); if not (State.can_fix err) then ( L.verbose (fun m -> m "CANNOT FIX!"); diff --git a/GillianCore/engine/FOLogic/Reduction.ml b/GillianCore/engine/FOLogic/Reduction.ml index 3f37bb8a..055d33db 100644 --- a/GillianCore/engine/FOLogic/Reduction.ml +++ b/GillianCore/engine/FOLogic/Reduction.ml @@ -3201,7 +3201,7 @@ let reduce_assertion_loop (gamma : Type_env.t) (a : Asrt.t) : Asrt.t = let fe = reduce_lexpr_loop ~matching pfs gamma in - let f : Asrt.simple -> Asrt.t = function + let f : Asrt.atom -> Asrt.t = function (* Empty heap *) | Asrt.Emp -> [] (* Star *) diff --git a/GillianCore/engine/FOLogic/Simplifications.ml b/GillianCore/engine/FOLogic/Simplifications.ml index 02bf2d3b..e2f6f462 100644 --- a/GillianCore/engine/FOLogic/Simplifications.ml +++ b/GillianCore/engine/FOLogic/Simplifications.ml @@ -997,7 +997,7 @@ let admissible_assertion (a : Asrt.t) : bool = let a = Asrt.pvars_to_lvars a in - let separate : Asrt.simple -> unit = function + let separate : Asrt.atom -> unit = function | Pure f -> PFS.extend pfs f | Types ets -> List.iter From 8a4c09b08e02700c08c898828ae441dc37a3a2cd Mon Sep 17 00:00:00 2001 From: N1ark Date: Wed, 11 Dec 2024 11:14:50 +0000 Subject: [PATCH 13/54] Fix CI --- GillianCore/engine/Abstraction/LogicPreprocessing.ml | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/GillianCore/engine/Abstraction/LogicPreprocessing.ml b/GillianCore/engine/Abstraction/LogicPreprocessing.ml index 71784fd4..60c91108 100644 --- a/GillianCore/engine/Abstraction/LogicPreprocessing.ml +++ b/GillianCore/engine/Abstraction/LogicPreprocessing.ml @@ -413,7 +413,8 @@ let unfold_proc (preds : (string, Pred.t) Hashtbl.t) (rec_info : (string, bool) Hashtbl.t) (proc : ('a, int) Proc.t) : ('a, int) Proc.t = - Logging.normal (fun f -> f "UNFOLD_PROC ! %a" Proc.pp_indexed proc); + Logging.normal (fun f -> + f "UNFOLD_PROC ! %a" (Proc.pp_indexed ~pp_annot:Fmt.nop) proc); let new_spec = Option.map (unfold_spec preds rec_info) proc.proc_spec in let new_body = Array.map From 2ccd90feef131b6b74f10132aeccceaff8d90d26 Mon Sep 17 00:00:00 2001 From: N1ark Date: Tue, 17 Dec 2024 01:14:08 +0000 Subject: [PATCH 14/54] Fix incorrect `auto_unfold` --- .../engine/Abstraction/LogicPreprocessing.ml | 23 +++++++++---------- 1 file changed, 11 insertions(+), 12 deletions(-) diff --git a/GillianCore/engine/Abstraction/LogicPreprocessing.ml b/GillianCore/engine/Abstraction/LogicPreprocessing.ml index 60c91108..3e619b43 100644 --- a/GillianCore/engine/Abstraction/LogicPreprocessing.ml +++ b/GillianCore/engine/Abstraction/LogicPreprocessing.ml @@ -86,19 +86,18 @@ let rec auto_unfold raise (Failure ("Error: Can't auto_unfold predicate " ^ name))) | _ -> [ [ asrt ] ]) in - (* Now that all assertions have been unfolded to multiple options, do a cross - product of all options to get all possible combinations of assertions - options: Asrt.t list list, ie list of options to choose from - *) - let rec cross_product (options : Asrt.t list list) : Asrt.t list = - match options with - | [] -> [] - | [ o ] -> o - | o :: os -> - let rest = cross_product os in - List.concat_map (fun a -> List.map (fun b -> a @ b) rest) o + (* Now that all assertions have been unfolded to multiple options, do the + cross products of options + e.g. [[a1; a2]; [b1; b2]] -> [[a1; b1]; [a1; b2]; [a2; b1]; [a2; b2]] *) + let options = + List.fold_left + (fun acc asrts -> + List.concat_map + (fun asrt -> List.map (fun asrt' -> asrt @ asrt') asrts) + acc) + [ [] ] options in - cross_product options + List.filter Simplifications.admissible_assertion options (* * Return: Hashtbl from predicate name to boolean From ac9dc4dd9372ecb71793b733a164e7898509256f Mon Sep 17 00:00:00 2001 From: N1ark Date: Thu, 19 Dec 2024 06:32:01 +0000 Subject: [PATCH 15/54] So this works but is not Good(tm) --- GillianCore/engine/Abstraction/MP.ml | 3 ++- GillianCore/engine/Abstraction/MP.mli | 2 +- GillianCore/engine/Abstraction/Matcher.ml | 10 +++++++++- 3 files changed, 12 insertions(+), 3 deletions(-) diff --git a/GillianCore/engine/Abstraction/MP.ml b/GillianCore/engine/Abstraction/MP.ml index 1bb62b13..06248211 100644 --- a/GillianCore/engine/Abstraction/MP.ml +++ b/GillianCore/engine/Abstraction/MP.ml @@ -535,7 +535,7 @@ let ins_outs_assertion in ins_and_outs_from_lists kb (largs @ List.rev llie) lloe -let simplify_asrts a = +let simplify_asrts ?(sorted = true) a = let rec aux (a : Asrt.atom) : Asrt.atom list = match a with | Pure True | Emp -> [] @@ -549,6 +549,7 @@ let simplify_asrts a = in let atoms = List.concat_map aux a in if List.mem (Asrt.Pure False) atoms then [ Asrt.Pure False ] + else if not sorted then atoms else let overlapping, separating = List.partition Asrt.is_pure_asrt atoms in let overlapping = List.sort_uniq Stdlib.compare overlapping in diff --git a/GillianCore/engine/Abstraction/MP.mli b/GillianCore/engine/Abstraction/MP.mli index b36c27c1..42b4752d 100644 --- a/GillianCore/engine/Abstraction/MP.mli +++ b/GillianCore/engine/Abstraction/MP.mli @@ -53,7 +53,7 @@ val learn_expr : ?top_level:bool -> KB.t -> Gil_syntax.Expr.t -> Gil_syntax.Expr.t -> outs val ins_outs_expr : KB.t -> Expr.t -> Expr.t -> (KB.t * outs) list -val simplify_asrts : Asrt.t -> Asrt.t +val simplify_asrts : ?sorted:bool -> Asrt.t -> Asrt.t val s_init_atoms : preds:(string, int list) Hashtbl.t -> diff --git a/GillianCore/engine/Abstraction/Matcher.ml b/GillianCore/engine/Abstraction/Matcher.ml index d3b9c57c..bc7781de 100644 --- a/GillianCore/engine/Abstraction/Matcher.ml +++ b/GillianCore/engine/Abstraction/Matcher.ml @@ -768,7 +768,15 @@ module Make (State : SState.S) : "@[-----------------@\n\ -----------------@\n\ Produce assertion: @[%a@]@]" Asrt.pp a); - let sas = MP.simplify_asrts a in + let sas = MP.simplify_asrts ~sorted:false a in + let types, rest = + List.partition + (function + | Asrt.Types _ -> true + | _ -> false) + sas + in + let sas = types @ List.rev rest in produce_asrt_list astate subst sas let produce_posts (state : t) (subst : SVal.SESubst.t) (asrts : Asrt.t list) : From efb515d6e3103f88b400178dcc85895ac001bd12 Mon Sep 17 00:00:00 2001 From: N1ark Date: Thu, 19 Dec 2024 07:30:26 +0000 Subject: [PATCH 16/54] That's a fix i guess : ( --- Gillian-C/lib/MonadicSVal.ml | 21 +++++++++++++-------- 1 file changed, 13 insertions(+), 8 deletions(-) diff --git a/Gillian-C/lib/MonadicSVal.ml b/Gillian-C/lib/MonadicSVal.ml index b38b73f0..56ac6f4c 100644 --- a/Gillian-C/lib/MonadicSVal.ml +++ b/Gillian-C/lib/MonadicSVal.ml @@ -89,9 +89,9 @@ let of_gil_expr sval_e = let open Patterns in Logging.verbose (fun fmt -> fmt "OF_GIL_EXPR : %a" Expr.pp sval_e); let* sval_e = Delayed.reduce sval_e in - match%ent sval_e with - | undefined -> DO.some SUndefined - | obj -> + if%sat undefined sval_e then DO.some SUndefined + else + if%sat obj sval_e then let loc_expr = Expr.list_nth sval_e 0 in let ofs = Expr.list_nth sval_e 1 in let* ofs = Delayed.reduce ofs in @@ -105,11 +105,16 @@ let of_gil_expr sval_e = (aloc, learned) in DO.some ~learned (Sptr (loc, ofs)) - | int_typ -> DO.some (SVint (Expr.list_nth sval_e 1)) - | float_typ -> DO.some (SVfloat (Expr.list_nth sval_e 1)) - | long_typ -> DO.some (SVlong (Expr.list_nth sval_e 1)) - | single_typ -> DO.some (SVsingle (Expr.list_nth sval_e 1)) - | _ -> DO.none () + else + if%sat int_typ sval_e then DO.some (SVint (Expr.list_nth sval_e 1)) + else + if%sat float_typ sval_e then DO.some (SVfloat (Expr.list_nth sval_e 1)) + else + if%sat long_typ sval_e then DO.some (SVlong (Expr.list_nth sval_e 1)) + else + if%sat single_typ sval_e then + DO.some (SVsingle (Expr.list_nth sval_e 1)) + else DO.none () let of_gil_expr_exn sval_e = let* value_opt = of_gil_expr sval_e in From 77b69e7efba3743b17da1b768e0deac2eeab0fb5 Mon Sep 17 00:00:00 2001 From: N1ark Date: Thu, 19 Dec 2024 08:33:58 +0000 Subject: [PATCH 17/54] Re-sort assertions --- GillianCore/engine/Abstraction/MP.ml | 3 +-- GillianCore/engine/Abstraction/MP.mli | 2 +- 2 files changed, 2 insertions(+), 3 deletions(-) diff --git a/GillianCore/engine/Abstraction/MP.ml b/GillianCore/engine/Abstraction/MP.ml index 06248211..1bb62b13 100644 --- a/GillianCore/engine/Abstraction/MP.ml +++ b/GillianCore/engine/Abstraction/MP.ml @@ -535,7 +535,7 @@ let ins_outs_assertion in ins_and_outs_from_lists kb (largs @ List.rev llie) lloe -let simplify_asrts ?(sorted = true) a = +let simplify_asrts a = let rec aux (a : Asrt.atom) : Asrt.atom list = match a with | Pure True | Emp -> [] @@ -549,7 +549,6 @@ let simplify_asrts ?(sorted = true) a = in let atoms = List.concat_map aux a in if List.mem (Asrt.Pure False) atoms then [ Asrt.Pure False ] - else if not sorted then atoms else let overlapping, separating = List.partition Asrt.is_pure_asrt atoms in let overlapping = List.sort_uniq Stdlib.compare overlapping in diff --git a/GillianCore/engine/Abstraction/MP.mli b/GillianCore/engine/Abstraction/MP.mli index 42b4752d..b36c27c1 100644 --- a/GillianCore/engine/Abstraction/MP.mli +++ b/GillianCore/engine/Abstraction/MP.mli @@ -53,7 +53,7 @@ val learn_expr : ?top_level:bool -> KB.t -> Gil_syntax.Expr.t -> Gil_syntax.Expr.t -> outs val ins_outs_expr : KB.t -> Expr.t -> Expr.t -> (KB.t * outs) list -val simplify_asrts : ?sorted:bool -> Asrt.t -> Asrt.t +val simplify_asrts : Asrt.t -> Asrt.t val s_init_atoms : preds:(string, int list) Hashtbl.t -> From c91d2b2ba081f07b254ebffd0d858b4419969d58 Mon Sep 17 00:00:00 2001 From: N1ark Date: Thu, 19 Dec 2024 08:42:46 +0000 Subject: [PATCH 18/54] Re-sort !! --- GillianCore/engine/Abstraction/Matcher.ml | 10 +--------- 1 file changed, 1 insertion(+), 9 deletions(-) diff --git a/GillianCore/engine/Abstraction/Matcher.ml b/GillianCore/engine/Abstraction/Matcher.ml index bc7781de..d3b9c57c 100644 --- a/GillianCore/engine/Abstraction/Matcher.ml +++ b/GillianCore/engine/Abstraction/Matcher.ml @@ -768,15 +768,7 @@ module Make (State : SState.S) : "@[-----------------@\n\ -----------------@\n\ Produce assertion: @[%a@]@]" Asrt.pp a); - let sas = MP.simplify_asrts ~sorted:false a in - let types, rest = - List.partition - (function - | Asrt.Types _ -> true - | _ -> false) - sas - in - let sas = types @ List.rev rest in + let sas = MP.simplify_asrts a in produce_asrt_list astate subst sas let produce_posts (state : t) (subst : SVal.SESubst.t) (asrts : Asrt.t list) : From 9387638c1eeab3bc22174b3820ccb8e14bdcbe7c Mon Sep 17 00:00:00 2001 From: N1ark Date: Sun, 22 Dec 2024 17:46:45 +0100 Subject: [PATCH 19/54] Cleanup --- GillianCore/engine/Abstraction/Matcher.ml | 18 ++---------------- 1 file changed, 2 insertions(+), 16 deletions(-) diff --git a/GillianCore/engine/Abstraction/Matcher.ml b/GillianCore/engine/Abstraction/Matcher.ml index b765ef70..1f15f6e8 100644 --- a/GillianCore/engine/Abstraction/Matcher.ml +++ b/GillianCore/engine/Abstraction/Matcher.ml @@ -1750,23 +1750,9 @@ module Make (State : SState.S) : match tactic.try_fold with | Some fold_values -> ( let res = fold_guarded_with_vals astate fold_values in - let errors = - List.filter_map - (function - | Error e -> Some e - | _ -> None) - res - in + let successes, errors = Res_list.split res in match errors with - | [] -> - let successes = - List.filter_map - (function - | Ok x -> Some x - | _ -> None) - res - in - Ok successes + | [] -> Ok successes | _ -> let error_string = Fmt.str "%a" Fmt.(Dump.list string) errors in Error error_string) From c869ac8308b275c0c25b59b9f304bbad4764ccb4 Mon Sep 17 00:00:00 2001 From: N1ark Date: Sun, 22 Dec 2024 17:54:24 +0100 Subject: [PATCH 20/54] Make recovering of consume fuel-based --- GillianCore/engine/Abstraction/Matcher.ml | 9 ++++----- 1 file changed, 4 insertions(+), 5 deletions(-) diff --git a/GillianCore/engine/Abstraction/Matcher.ml b/GillianCore/engine/Abstraction/Matcher.ml index 1f15f6e8..c801fbe3 100644 --- a/GillianCore/engine/Abstraction/Matcher.ml +++ b/GillianCore/engine/Abstraction/Matcher.ml @@ -1567,13 +1567,13 @@ module Make (State : SState.S) : let subst_i = SVal.SESubst.copy subst in let can_fix errs = List.exists State.can_fix errs in - let rec handle_ret ~try_recover ret = + let rec handle_ret ~fuel ret = match ret with | Ok successes -> L.verbose (fun fmt -> fmt "Matcher.match_: Success (possibly empty)"); Res_list.just_oks successes | Error errs - when try_recover && !Config.unfolding + when fuel > 0 && !Config.unfolding && Exec_mode.is_verification_exec !Config.current_exec_mode && (not in_matching) && can_fix errs -> ( L.verbose (fun fmt -> fmt "Matcher.match_: Failure"); @@ -1607,8 +1607,7 @@ module Make (State : SState.S) : (* let subst'' = compose_substs (Subst.to_list subst_i) subst (Subst.init []) in *) let subst'' = SVal.SESubst.copy subst_i in let new_ret = match_mp ([ (astate, subst'', mp) ], []) in - (* We already tried recovering once and it failed, we stop here *) - handle_ret ~try_recover:false new_ret)) + handle_ret ~fuel:(fuel - 1) new_ret)) | Error errors -> L.verbose (fun fmt -> fmt "Matcher.match: Failure"); Res_list.just_errors errors @@ -1617,7 +1616,7 @@ module Make (State : SState.S) : { astate = AstateRec.from astate; subst; mp; match_kind } (fun _ -> let ret = match_mp ([ (astate, subst, mp) ], []) in - handle_ret ~try_recover:true ret) + handle_ret ~fuel:10 ret) and fold ?(in_matching = false) From f72153639fd5ca4af12c8ccce5ad46d6eb4c89ac Mon Sep 17 00:00:00 2001 From: N1ark Date: Mon, 23 Dec 2024 11:37:00 +0100 Subject: [PATCH 21/54] Use pipes --- .../engine/Abstraction/LogicPreprocessing.ml | 157 +++++++++--------- 1 file changed, 77 insertions(+), 80 deletions(-) diff --git a/GillianCore/engine/Abstraction/LogicPreprocessing.ml b/GillianCore/engine/Abstraction/LogicPreprocessing.ml index 3e619b43..2c7ed4e5 100644 --- a/GillianCore/engine/Abstraction/LogicPreprocessing.ml +++ b/GillianCore/engine/Abstraction/LogicPreprocessing.ml @@ -12,92 +12,89 @@ let rec auto_unfold (predicates : (string, Pred.t) Hashtbl.t) (rec_tbl : (string, bool) Hashtbl.t) (asrt : Asrt.t) : Asrt.t list = - let au_no_rec = auto_unfold ~unfold_rec_predicates:false predicates rec_tbl in - let options = - asrt - |> List.map (fun asrt -> - match asrt with - (* We don't unfold: - - Recursive predicates (except in some very specific cases) - - predicates marked with no-unfold - - predicates with a guard *) - | Asrt.Pred (name, _) - when (Hashtbl.find rec_tbl name && not unfold_rec_predicates) - || - let pred = Hashtbl.find predicates name in - pred.pred_nounfold || Option.is_some pred.pred_guard -> - [ [ asrt ] ] - | Pred (name, args) when Hashtbl.mem unfolded_preds name -> - L.verbose (fun fmt -> - fmt "Unfolding predicate: %s with nounfold %b" name - (Hashtbl.find predicates name).pred_nounfold); - let pred = Hashtbl.find unfolded_preds name in + asrt + |> List.map (fun asrt -> + match asrt with + (* We don't unfold: + - Recursive predicates (except in some very specific cases) + - predicates marked with no-unfold + - predicates with a guard *) + | Asrt.Pred (name, _) + when (Hashtbl.find rec_tbl name && not unfold_rec_predicates) + || + let pred = Hashtbl.find predicates name in + pred.pred_nounfold || Option.is_some pred.pred_guard -> + [ [ asrt ] ] + | Pred (name, args) when Hashtbl.mem unfolded_preds name -> + L.verbose (fun fmt -> + fmt "Unfolding predicate: %s with nounfold %b" name + (Hashtbl.find predicates name).pred_nounfold); + let pred = Hashtbl.find unfolded_preds name in + let params, _ = List.split pred.pred_params in + let combined = + try List.combine params args + with Invalid_argument _ -> + Fmt.failwith + "Impossible to auto unfold predicate %s. Used with %i args \ + instead of %i" + name (List.length args) (List.length params) + in + let subst = SVal.SSubst.init combined in + let defs = List.map (fun (_, def) -> def) pred.pred_definitions in + List.map (SVal.SSubst.substitute_asrt subst ~partial:false) defs + | Pred (name, args) -> ( + try + L.tmi (fun fmt -> + fmt "AutoUnfold: %a : %s" Asrt.pp_atom asrt name); + let pred : Pred.t = Hashtbl.find predicates name in + (* If it is not, replace the predicate assertion for the list of its definitions + substituting the formal parameters of the predicate with the corresponding + logical expressions in the argument list *) let params, _ = List.split pred.pred_params in - let combined = - try List.combine params args - with Invalid_argument _ -> - Fmt.failwith - "Impossible to auto unfold predicate %s. Used with %i \ - args instead of %i" - name (List.length args) (List.length params) + let subst = SVal.SSubst.init (List.combine params args) in + Logging.tmi (fun fmt -> + fmt "PREDICATE %s has %d definitions" pred.pred_name + (List.length pred.pred_definitions)); + let new_asrts = + List.map + (fun (_, a) -> + L.tmi (fun fmt -> + fmt "Before Auto Unfolding: %a" Asrt.pp a); + let facts = + List.map (fun fact -> Asrt.Pure fact) pred.pred_facts + in + let a = a @ facts in + let result = + SVal.SSubst.substitute_asrt subst ~partial:false a + in + L.tmi (fun fmt -> + fmt "After Auto Unfolding: %a" Asrt.pp result); + result) + pred.pred_definitions in - let subst = SVal.SSubst.init combined in - let defs = - List.map (fun (_, def) -> def) pred.pred_definitions + + (* FIXME: + If we processed the predicate definitions in order the recursive call to auto unfold + would be avoided *) + let au_no_rec = + auto_unfold ~unfold_rec_predicates:false predicates rec_tbl in - List.map (SVal.SSubst.substitute_asrt subst ~partial:false) defs - | Pred (name, args) -> ( - try - L.tmi (fun fmt -> - fmt "AutoUnfold: %a : %s" Asrt.pp_atom asrt name); - let pred : Pred.t = Hashtbl.find predicates name in - (* If it is not, replace the predicate assertion for the list of its definitions - substituting the formal parameters of the predicate with the corresponding - logical expressions in the argument list *) - let params, _ = List.split pred.pred_params in - let subst = SVal.SSubst.init (List.combine params args) in - Logging.tmi (fun fmt -> - fmt "PREDICATE %s has %d definitions" pred.pred_name - (List.length pred.pred_definitions)); - let new_asrts = - List.map - (fun (_, a) -> - L.tmi (fun fmt -> - fmt "Before Auto Unfolding: %a" Asrt.pp a); - let facts = - List.map (fun fact -> Asrt.Pure fact) pred.pred_facts - in - let a = a @ facts in - let result = - SVal.SSubst.substitute_asrt subst ~partial:false a - in - L.tmi (fun fmt -> - fmt "After Auto Unfolding: %a" Asrt.pp result); - result) - pred.pred_definitions - in - - (* FIXME: - If we processed the predicate definitions in order the recursive call to auto unfold - would be avoided *) - let result = List.concat_map au_no_rec new_asrts in - List.filter Simplifications.admissible_assertion result - with Not_found -> - raise (Failure ("Error: Can't auto_unfold predicate " ^ name))) - | _ -> [ [ asrt ] ]) - in + let result = List.concat_map au_no_rec new_asrts in + List.filter Simplifications.admissible_assertion result + with Not_found -> + raise (Failure ("Error: Can't auto_unfold predicate " ^ name))) + | _ -> [ [ asrt ] ]) (* Now that all assertions have been unfolded to multiple options, do the cross products of options e.g. [[a1; a2]; [b1; b2]] -> [[a1; b1]; [a1; b2]; [a2; b1]; [a2; b2]] *) - let options = - List.fold_left - (fun acc asrts -> - List.concat_map - (fun asrt -> List.map (fun asrt' -> asrt @ asrt') asrts) - acc) - [ [] ] options - in - List.filter Simplifications.admissible_assertion options + |> List.map (List.map List.rev) + |> List.fold_left + (fun acc asrts -> + List.concat_map + (fun asrt -> List.map (fun asrt' -> asrt' @ asrt) asrts) + acc) + [ [] ] + |> List.filter Simplifications.admissible_assertion (* * Return: Hashtbl from predicate name to boolean From a8d346fa39d3827e97afd3747fd64747f285973a Mon Sep 17 00:00:00 2001 From: N1ark Date: Mon, 23 Dec 2024 14:14:20 +0100 Subject: [PATCH 22/54] Disable asrt sort in produce, avoids branch expl --- .../engine/Abstraction/LogicPreprocessing.ml | 136 +++++++++--------- GillianCore/engine/Abstraction/MP.ml | 3 +- GillianCore/engine/Abstraction/MP.mli | 2 +- GillianCore/engine/Abstraction/Matcher.ml | 2 +- 4 files changed, 70 insertions(+), 73 deletions(-) diff --git a/GillianCore/engine/Abstraction/LogicPreprocessing.ml b/GillianCore/engine/Abstraction/LogicPreprocessing.ml index 2c7ed4e5..3f3c1a7a 100644 --- a/GillianCore/engine/Abstraction/LogicPreprocessing.ml +++ b/GillianCore/engine/Abstraction/LogicPreprocessing.ml @@ -13,81 +13,77 @@ let rec auto_unfold (rec_tbl : (string, bool) Hashtbl.t) (asrt : Asrt.t) : Asrt.t list = asrt - |> List.map (fun asrt -> - match asrt with - (* We don't unfold: - - Recursive predicates (except in some very specific cases) - - predicates marked with no-unfold - - predicates with a guard *) - | Asrt.Pred (name, _) - when (Hashtbl.find rec_tbl name && not unfold_rec_predicates) - || - let pred = Hashtbl.find predicates name in - pred.pred_nounfold || Option.is_some pred.pred_guard -> - [ [ asrt ] ] - | Pred (name, args) when Hashtbl.mem unfolded_preds name -> - L.verbose (fun fmt -> - fmt "Unfolding predicate: %s with nounfold %b" name - (Hashtbl.find predicates name).pred_nounfold); - let pred = Hashtbl.find unfolded_preds name in + |> List.map (function + (* We don't unfold: + - Recursive predicates (except in some very specific cases) + - predicates marked with no-unfold + - predicates with a guard *) + | Asrt.Pred (name, _) as asrt + when (Hashtbl.find rec_tbl name && not unfold_rec_predicates) + || + let pred = Hashtbl.find predicates name in + pred.pred_nounfold || Option.is_some pred.pred_guard -> + [ [ asrt ] ] + | Pred (name, args) when Hashtbl.mem unfolded_preds name -> + L.verbose (fun fmt -> + fmt "Unfolding predicate: %s with nounfold %b" name + (Hashtbl.find predicates name).pred_nounfold); + let pred = Hashtbl.find unfolded_preds name in + let params, _ = List.split pred.pred_params in + let combined = + try List.combine params args + with Invalid_argument _ -> + Fmt.failwith + "Impossible to auto unfold predicate %s. Used with %i args \ + instead of %i" + name (List.length args) (List.length params) + in + let subst = SVal.SSubst.init combined in + let defs = List.map (fun (_, def) -> def) pred.pred_definitions in + List.map (SVal.SSubst.substitute_asrt subst ~partial:false) defs + | Pred (name, args) as asrt -> ( + try + L.tmi (fun fmt -> fmt "AutoUnfold: %a : %s" Asrt.pp_atom asrt name); + let pred : Pred.t = Hashtbl.find predicates name in + (* If it is not, replace the predicate assertion for the list of its definitions + substituting the formal parameters of the predicate with the corresponding + logical expressions in the argument list *) let params, _ = List.split pred.pred_params in - let combined = - try List.combine params args - with Invalid_argument _ -> - Fmt.failwith - "Impossible to auto unfold predicate %s. Used with %i args \ - instead of %i" - name (List.length args) (List.length params) + let subst = SVal.SSubst.init (List.combine params args) in + L.tmi (fun fmt -> + fmt "PREDICATE %s has %d definitions" pred.pred_name + (List.length pred.pred_definitions)); + let new_asrts = + List.map + (fun (_, a) -> + L.tmi (fun fmt -> fmt "Before Auto Unfolding: %a" Asrt.pp a); + let facts = + List.map (fun fact -> Asrt.Pure fact) pred.pred_facts + in + let a = a @ facts in + let result = + SVal.SSubst.substitute_asrt subst ~partial:false a + in + L.tmi (fun fmt -> + fmt "After Auto Unfolding: %a" Asrt.pp result); + result) + pred.pred_definitions in - let subst = SVal.SSubst.init combined in - let defs = List.map (fun (_, def) -> def) pred.pred_definitions in - List.map (SVal.SSubst.substitute_asrt subst ~partial:false) defs - | Pred (name, args) -> ( - try - L.tmi (fun fmt -> - fmt "AutoUnfold: %a : %s" Asrt.pp_atom asrt name); - let pred : Pred.t = Hashtbl.find predicates name in - (* If it is not, replace the predicate assertion for the list of its definitions - substituting the formal parameters of the predicate with the corresponding - logical expressions in the argument list *) - let params, _ = List.split pred.pred_params in - let subst = SVal.SSubst.init (List.combine params args) in - Logging.tmi (fun fmt -> - fmt "PREDICATE %s has %d definitions" pred.pred_name - (List.length pred.pred_definitions)); - let new_asrts = - List.map - (fun (_, a) -> - L.tmi (fun fmt -> - fmt "Before Auto Unfolding: %a" Asrt.pp a); - let facts = - List.map (fun fact -> Asrt.Pure fact) pred.pred_facts - in - let a = a @ facts in - let result = - SVal.SSubst.substitute_asrt subst ~partial:false a - in - L.tmi (fun fmt -> - fmt "After Auto Unfolding: %a" Asrt.pp result); - result) - pred.pred_definitions - in - - (* FIXME: - If we processed the predicate definitions in order the recursive call to auto unfold - would be avoided *) - let au_no_rec = - auto_unfold ~unfold_rec_predicates:false predicates rec_tbl - in - let result = List.concat_map au_no_rec new_asrts in - List.filter Simplifications.admissible_assertion result - with Not_found -> - raise (Failure ("Error: Can't auto_unfold predicate " ^ name))) - | _ -> [ [ asrt ] ]) + + (* FIXME: + If we processed the predicate definitions in order the recursive call to auto unfold + would be avoided *) + let au_no_rec = + auto_unfold ~unfold_rec_predicates:false predicates rec_tbl + in + let result = List.concat_map au_no_rec new_asrts in + List.filter Simplifications.admissible_assertion result + with Not_found -> + raise (Failure ("Error: Can't auto_unfold predicate " ^ name))) + | asrt -> [ [ asrt ] ]) (* Now that all assertions have been unfolded to multiple options, do the cross products of options e.g. [[a1; a2]; [b1; b2]] -> [[a1; b1]; [a1; b2]; [a2; b1]; [a2; b2]] *) - |> List.map (List.map List.rev) |> List.fold_left (fun acc asrts -> List.concat_map diff --git a/GillianCore/engine/Abstraction/MP.ml b/GillianCore/engine/Abstraction/MP.ml index 1bb62b13..06248211 100644 --- a/GillianCore/engine/Abstraction/MP.ml +++ b/GillianCore/engine/Abstraction/MP.ml @@ -535,7 +535,7 @@ let ins_outs_assertion in ins_and_outs_from_lists kb (largs @ List.rev llie) lloe -let simplify_asrts a = +let simplify_asrts ?(sorted = true) a = let rec aux (a : Asrt.atom) : Asrt.atom list = match a with | Pure True | Emp -> [] @@ -549,6 +549,7 @@ let simplify_asrts a = in let atoms = List.concat_map aux a in if List.mem (Asrt.Pure False) atoms then [ Asrt.Pure False ] + else if not sorted then atoms else let overlapping, separating = List.partition Asrt.is_pure_asrt atoms in let overlapping = List.sort_uniq Stdlib.compare overlapping in diff --git a/GillianCore/engine/Abstraction/MP.mli b/GillianCore/engine/Abstraction/MP.mli index b36c27c1..42b4752d 100644 --- a/GillianCore/engine/Abstraction/MP.mli +++ b/GillianCore/engine/Abstraction/MP.mli @@ -53,7 +53,7 @@ val learn_expr : ?top_level:bool -> KB.t -> Gil_syntax.Expr.t -> Gil_syntax.Expr.t -> outs val ins_outs_expr : KB.t -> Expr.t -> Expr.t -> (KB.t * outs) list -val simplify_asrts : Asrt.t -> Asrt.t +val simplify_asrts : ?sorted:bool -> Asrt.t -> Asrt.t val s_init_atoms : preds:(string, int list) Hashtbl.t -> diff --git a/GillianCore/engine/Abstraction/Matcher.ml b/GillianCore/engine/Abstraction/Matcher.ml index c801fbe3..edd6a695 100644 --- a/GillianCore/engine/Abstraction/Matcher.ml +++ b/GillianCore/engine/Abstraction/Matcher.ml @@ -731,7 +731,7 @@ module Make (State : SState.S) : "@[-----------------@\n\ -----------------@\n\ Produce assertion: @[%a@]@]" Asrt.pp a); - let sas = MP.simplify_asrts a in + let sas = MP.simplify_asrts ~sorted:false a in produce_asrt_list astate subst sas let produce_posts (state : t) (subst : SVal.SESubst.t) (asrts : Asrt.t list) : From 156e062cad78d1fc8c3eb8fcc26becd19fd3204e Mon Sep 17 00:00:00 2001 From: N1ark Date: Mon, 23 Dec 2024 15:46:42 +0100 Subject: [PATCH 23/54] Nevermind I guess we're sorting --- GillianCore/engine/Abstraction/Matcher.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/GillianCore/engine/Abstraction/Matcher.ml b/GillianCore/engine/Abstraction/Matcher.ml index edd6a695..c801fbe3 100644 --- a/GillianCore/engine/Abstraction/Matcher.ml +++ b/GillianCore/engine/Abstraction/Matcher.ml @@ -731,7 +731,7 @@ module Make (State : SState.S) : "@[-----------------@\n\ -----------------@\n\ Produce assertion: @[%a@]@]" Asrt.pp a); - let sas = MP.simplify_asrts ~sorted:false a in + let sas = MP.simplify_asrts a in produce_asrt_list astate subst sas let produce_posts (state : t) (subst : SVal.SESubst.t) (asrts : Asrt.t list) : From 93595ac8e747da350ef9f4a4260d7b32ed8c578f Mon Sep 17 00:00:00 2001 From: N1ark Date: Mon, 23 Dec 2024 19:25:45 +0100 Subject: [PATCH 24/54] Remove from syntax --- GillianCore/GIL_Syntax/Asrt.ml | 37 +- GillianCore/GIL_Syntax/BinOp.ml | 24 +- GillianCore/GIL_Syntax/Expr.ml | 89 +++-- GillianCore/GIL_Syntax/Formula.ml | 455 ---------------------- GillianCore/GIL_Syntax/Gil_syntax.ml | 1 - GillianCore/GIL_Syntax/Gil_syntax.mli | 487 ++++++------------------ GillianCore/GIL_Syntax/LCmd.ml | 35 +- GillianCore/GIL_Syntax/Lemma.ml | 2 +- GillianCore/GIL_Syntax/Pred.ml | 9 +- GillianCore/GIL_Syntax/TypeDef__.ml | 45 +-- GillianCore/GIL_Syntax/UnOp.ml | 6 +- GillianCore/GIL_Syntax/Visitors.ml | 4 +- GillianCore/GIL_Syntax/test/Visitors.ml | 2 +- GillianCore/gil_parser/GIL_Parser.mly | 60 +-- 14 files changed, 275 insertions(+), 981 deletions(-) delete mode 100644 GillianCore/GIL_Syntax/Formula.ml diff --git a/GillianCore/GIL_Syntax/Asrt.ml b/GillianCore/GIL_Syntax/Asrt.ml index ed3cece0..2450fa3d 100644 --- a/GillianCore/GIL_Syntax/Asrt.ml +++ b/GillianCore/GIL_Syntax/Asrt.ml @@ -2,7 +2,7 @@ type atom = TypeDef__.assertion_atom = | Emp (** Empty heap *) | Pred of string * Expr.t list (** Predicates *) - | Pure of Formula.t (** Pure formula *) + | Pure of Expr.t (** Pure formula *) | Types of (Expr.t * Type.t) list (** Typing assertion *) | CorePred of string * Expr.t list * Expr.t list (** Core assertion *) @@ -20,9 +20,9 @@ let of_yojson = TypeDef__.assertion_of_yojson let compare x y = let cmp = Stdlib.compare in match (x, y) with - | Pure (Eq (PVar x, _)), Pure (Eq (PVar y, _)) -> cmp x y - | Pure (Eq (PVar _, _)), _ -> -1 - | _, Pure (Eq (PVar _, _)) -> 1 + | Pure (BinOp (PVar x, Equal, _)), Pure (BinOp (PVar y, Equal, _)) -> cmp x y + | Pure (BinOp (PVar _, Equal, _)), _ -> -1 + | _, Pure (BinOp (PVar _, Equal, _)) -> 1 | Pure _, Pure _ -> cmp x y | Pure _, _ -> -1 | _, Pure _ -> 1 @@ -69,11 +69,11 @@ end module Set = Set.Make (MyAssertion) (** Deprecated, use {!Visitors.endo} instead. *) -let map (f_e : Expr.t -> Expr.t) (f_p : Formula.t -> Formula.t) : t -> t = +let map (f_e : Expr.t -> Expr.t) : t -> t = List.map (function | Emp -> Emp | Pred (s, le) -> Pred (s, List.map f_e le) - | Pure form -> Pure (f_p form) + | Pure form -> Pure (f_e form) | Types lt -> Types (List.map (fun (exp, typ) -> (f_e exp, typ)) lt) | CorePred (x, es1, es2) -> CorePred (x, List.map f_e es1, List.map f_e es2) | Wand { lhs = lhs_pred, lhs_args; rhs = rhs_pred, rhs_args } -> @@ -83,11 +83,6 @@ let map (f_e : Expr.t -> Expr.t) (f_p : Formula.t -> Formula.t) : t -> t = rhs = (rhs_pred, List.map f_e rhs_args); }) -(* Get all the logical expressions of --a-- that denote a list - and are not logical variables *) -let list_lexprs : t -> Expr.Set.t = - Formula.list_lexprs_collector#visit_assertion () - (* Get all the logical variables in --a-- *) let lvars : t -> SS.t = Visitors.Collectors.lvar_collector#visit_assertion SS.empty @@ -116,7 +111,7 @@ let pred_names : t -> string list = collector#visit_assertion () (* Returns a list with the pure assertions that occur in --a-- *) -let pure_asrts : t -> Formula.t list = +let pure_asrts : t -> Expr.t list = let collector = object inherit [_] Visitors.reduce @@ -131,16 +126,16 @@ let is_pure_asrt : atom -> bool = function | Pred _ | CorePred _ | Wand _ -> false | _ -> true -(* Eliminate LStar and LTypes assertions. - LTypes disappears. LStar is replaced by LAnd. +(* Eliminate Emp assertions. + Pure assertions are converted to a single formula. This function expects its argument to be a PURE assertion. *) -let make_pure (a : t) : Formula.t = +let make_pure (a : t) : Expr.t = a |> List.filter_map (function | Pure f -> Some f | Emp -> None | _ -> raise (Failure "DEATH. make_pure received unpure assertion")) - |> Formula.conjunct + |> Expr.conjunct (** GIL logic assertions *) let _pp_atom ?(e_pp : Format.formatter -> Expr.t -> unit = Expr.pp) fmt = @@ -152,7 +147,7 @@ let _pp_atom ?(e_pp : Format.formatter -> Expr.t -> unit = Expr.pp) fmt = | Types tls -> let pp_tl f (e, t) = Fmt.pf f "%a : %s" e_pp e (Type.str t) in Fmt.pf fmt "types(@[%a@])" (Fmt.list ~sep:Fmt.comma pp_tl) tls - | Pure f -> Formula.pp fmt f + | Pure f -> e_pp fmt f | CorePred (a, ins, outs) -> let pp_e_l = Fmt.list ~sep:Fmt.comma e_pp in Fmt.pf fmt "@[<%s>(%a; %a)@]" a pp_e_l ins pp_e_l outs @@ -175,11 +170,9 @@ let pp = _pp ~e_pp:Expr.pp let full_pp = _pp ~e_pp:Expr.full_pp let subst_clocs (subst : string -> Expr.t) : t -> t = - map (Expr.subst_clocs subst) (Formula.subst_clocs subst) + map (Expr.subst_clocs subst) let subst_expr_for_expr ~(to_subst : Expr.t) ~(subst_with : Expr.t) : t -> t = - map - (Expr.subst_expr_for_expr ~to_subst ~subst_with) - (Formula.subst_expr_for_expr ~to_subst ~subst_with) + map (Expr.subst_expr_for_expr ~to_subst ~subst_with) -let pvars_to_lvars : t -> t = map Expr.pvars_to_lvars Formula.pvars_to_lvars +let pvars_to_lvars : t -> t = map Expr.pvars_to_lvars diff --git a/GillianCore/GIL_Syntax/BinOp.ml b/GillianCore/GIL_Syntax/BinOp.ml index 9fc089b4..542b3c9a 100644 --- a/GillianCore/GIL_Syntax/BinOp.ml +++ b/GillianCore/GIL_Syntax/BinOp.ml @@ -17,11 +17,10 @@ type t = TypeDef__.binop = | FTimes (** Float multiplication *) | FDiv (** Float division *) | FMod (** Float modulus *) - | SLessThan (** Less or equal for strings *) (* Boolean *) - | BAnd (** Boolean conjunction *) - | BOr (** Boolean disjunction *) - | BImpl (** Boolean implication *) + | And (** Boolean conjunction *) + | Or (** Boolean disjunction *) + | Impl (** Boolean implication *) (* Bitwise *) | BitwiseAnd (** Bitwise conjunction *) | BitwiseOr (** Bitwise disjunction *) @@ -51,10 +50,11 @@ type t = TypeDef__.binop = (* Strings *) | StrCat (** String concatenation *) | StrNth (** Nth element of a string *) + | StrLess (** Less or equal for strings *) (* Sets *) | SetDiff (** Set difference *) - | BSetMem (** Set membership *) - | BSetSub (** Subset *) + | SetMem (** Set membership *) + | SetSub (** Subset *) [@@deriving eq, ord] let to_yojson = TypeDef__.binop_to_yojson @@ -77,10 +77,10 @@ let str (x : t) = | FTimes -> "*" | FDiv -> "/" | FMod -> "%" - | SLessThan -> "s<" - | BAnd -> "and" - | BOr -> "or" - | BImpl -> "==>" + | StrLess -> "s<" + | And -> "and" + | Or -> "or" + | Impl -> "==>" | BitwiseAnd -> "&" | BitwiseOr -> "|" | BitwiseXor -> "^" @@ -106,5 +106,5 @@ let str (x : t) = | StrCat -> "++" | StrNth -> "s-nth" | SetDiff -> "-d-" - | BSetMem -> "-e-" - | BSetSub -> "-s-" + | SetMem -> "-e-" + | SetSub -> "-s-" diff --git a/GillianCore/GIL_Syntax/Expr.ml b/GillianCore/GIL_Syntax/Expr.ml index 76bbda5d..395b1b38 100644 --- a/GillianCore/GIL_Syntax/Expr.ml +++ b/GillianCore/GIL_Syntax/Expr.ml @@ -14,7 +14,7 @@ type t = TypeDef__.expr = | ESet of t list (** Sets of expressions *) | Exists of (string * Type.t option) list * t (** Existential quantification. This is now a circus because the separation between Formula and Expr doesn't make sense anymore. *) - | EForall of (string * Type.t option) list * t + | ForAll of (string * Type.t option) list * t [@@deriving eq, ord] let to_yojson = TypeDef__.expr_to_yojson @@ -242,11 +242,42 @@ module Infix = struct let not a = match a with | Lit (Bool a) -> Lit (Bool (not a)) - | x -> UnOp (UNot, x) + | x -> UnOp (Not, x) + + let ( && ) a b = + match (a, b) with + | Lit (Bool x), Lit (Bool y) -> Lit (Bool (x && y)) + | Lit (Bool true), x | x, Lit (Bool true) -> x + | Lit (Bool false), _ | _, Lit (Bool false) -> Lit (Bool false) + | _ -> BinOp (a, And, b) + + let ( || ) a b = + match (a, b) with + | Lit (Bool x), Lit (Bool y) -> Lit (Bool (x || y)) + | Lit (Bool false), x | x, Lit (Bool false) -> x + | Lit (Bool true), _ | _, Lit (Bool true) -> Lit (Bool true) + | _ -> BinOp (a, Or, b) + + let ( ==> ) a b = + match (a, b) with + | Lit (Bool true), x | x, Lit (Bool true) -> x + | Lit (Bool false), _ -> Lit (Bool true) + | x, Lit (Bool false) -> not x + | _ -> BinOp (a, Impl, b) let ( @+ ) = list_cat end +let conjunct = function + | [] -> Lit (Bool true) + | [ x ] -> x + | hd :: tl -> List.fold_left (fun acc x -> Infix.( && ) acc x) hd tl + +let disjunct = function + | [] -> Lit (Bool false) + | [ x ] -> x + | hd :: tl -> List.fold_left (fun acc x -> Infix.( || ) acc x) hd tl + module MyExpr = struct type nonrec t = t @@ -258,30 +289,6 @@ end module Set = Set.Make (MyExpr) module Map = Map.Make (MyExpr) -(** Map over expressions *) - -(* let rec map (f_before : t -> t * bool) (f_after : (t -> t) option) (expr : t) : - t = - (* Apply the mapping *) - let map_e = map f_before f_after in - let f_after = Option.value ~default:(fun x -> x) f_after in - - let mapped_expr, recurse = f_before expr in - if not recurse then mapped_expr - else - (* Map recursively to expressions *) - let mapped_expr = - match mapped_expr with - | Lit _ | PVar _ | LVar _ | ALoc _ -> mapped_expr - | UnOp (op, e) -> UnOp (op, map_e e) - | BinOp (e1, op, e2) -> BinOp (map_e e1, op, map_e e2) - | LstSub (e1, e2, e3) -> LstSub (map_e e1, map_e e2, map_e e3) - | NOp (op, es) -> NOp (op, List.map map_e es) - | EList es -> EList (List.map map_e es) - | ESet es -> ESet (List.map map_e es) - in - f_after mapped_expr *) - (** Optional map over expressions *) let rec map_opt @@ -318,9 +325,9 @@ let rec map_opt match map_e e with | Some e' -> Some (Exists (bt, e')) | _ -> None) - | EForall (bt, e) -> ( + | ForAll (bt, e) -> ( match map_e e with - | Some e' -> Some (EForall (bt, e')) + | Some e' -> Some (ForAll (bt, e')) | _ -> None) in Option.map f_after mapped_expr @@ -354,7 +361,7 @@ let rec pp fmt e = Fmt.pf fmt "(exists %a . %a)" (Fmt.list ~sep:Fmt.comma pp_var_with_type) bt pp e - | EForall (bt, e) -> + | ForAll (bt, e) -> Fmt.pf fmt "(forall %a . %a)" (Fmt.list ~sep:Fmt.comma pp_var_with_type) bt pp e @@ -418,7 +425,7 @@ let rec is_concrete (le : t) : bool = match le with | Lit _ | PVar _ -> true - | LVar _ | ALoc _ | Exists _ | EForall _ -> false + | LVar _ | ALoc _ | Exists _ | ForAll _ -> false | UnOp (_, e) -> loop [ e ] | BinOp (e1, _, e2) -> loop [ e1; e2 ] | LstSub (e1, e2, e3) -> loop [ e1; e2; e3 ] @@ -466,6 +473,28 @@ let loc_from_loc_name (loc_name : string) : t = (** {2 Visitors} *) +let rec push_in_negations_off (a : t) : t = + let f_off = push_in_negations_off in + let f_on = push_in_negations_on in + match a with + | BinOp (a1, And, a2) -> BinOp (f_off a1, And, f_off a2) + | BinOp (a1, Or, a2) -> BinOp (f_off a1, Or, f_off a2) + | UnOp (Not, a1) -> f_on a1 + | ForAll (bt, a) -> ForAll (bt, f_off a) + | _ -> a + +and push_in_negations_on (a : t) : t = + let f_off = push_in_negations_off in + let f_on = push_in_negations_on in + match a with + | BinOp (a1, And, a2) -> BinOp (f_on a1, Or, f_on a2) + | BinOp (a1, Or, a2) -> BinOp (f_on a1, And, f_on a2) + | Lit (Bool b) -> Lit (Bool (not b)) + | UnOp (Not, a) -> f_off a + | _ -> UnOp (Not, a) + +and push_in_negations (a : t) : t = push_in_negations_off a + let subst_expr_for_expr ~to_subst ~subst_with expr = let v = object diff --git a/GillianCore/GIL_Syntax/Formula.ml b/GillianCore/GIL_Syntax/Formula.ml deleted file mode 100644 index ae52b295..00000000 --- a/GillianCore/GIL_Syntax/Formula.ml +++ /dev/null @@ -1,455 +0,0 @@ -type t = TypeDef__.formula = - | True (** Logical true *) - | False (** Logical false *) - | Not of t (** Logical negation *) - | And of t * t (** Logical conjunction *) - | Or of t * t (** Logical disjunction *) - | Eq of Expr.t * Expr.t (** Expression equality *) - | Impl of t * t (** Logical implication *) - | FLess of Expr.t * Expr.t (** Expression less-than for numbers *) - | FLessEq of Expr.t * Expr.t (** Expression less-than-or-equal for numbers *) - | ILess of Expr.t * Expr.t (** Expression less-than for integers *) - | ILessEq of Expr.t * Expr.t - (** Expression less-than-or-equal for integeres *) - | StrLess of Expr.t * Expr.t (** Expression less-than for strings *) - | SetMem of Expr.t * Expr.t (** Set membership *) - | SetSub of Expr.t * Expr.t (** Set subsetness *) - | ForAll of (string * Type.t option) list * t (** Forall *) - | IsInt of Expr.t (** IsInt e <=> (e : float) /\ (e % 1. == 0) *) -[@@deriving eq] - -let to_yojson = TypeDef__.formula_to_yojson -let of_yojson = TypeDef__.formula_of_yojson -let compare = Stdlib.compare -let of_bool b = if b then True else False - -module MyFormula = struct - type nonrec t = t - - let compare = Stdlib.compare -end - -module Set = Set.Make (MyFormula) - -let list_lexprs_collector = - object (self) - inherit [_] Visitors.reduce as super - method private zero = Expr.Set.empty - method private plus = Expr.Set.union - method! visit_'label () (_ : int) = self#zero - method! visit_'annot () () = self#zero - - method! visit_expr () e = - match e with - | Lit (LList _) - | EList _ - | NOp (LstCat, _) - | UnOp ((Car | Cdr | LstLen), _) -> Expr.Set.singleton e - | _ -> super#visit_expr () e - end - -(** Apply function f to the logic expressions in an assertion, recursively when f_a returns (new_asrt, true). *) -let rec map - (f_a_before : (t -> t * bool) option) - (f_a_after : (t -> t) option) - (f_e : (Expr.t -> Expr.t) option) - (a : t) : t = - (* Map recursively to assertions and expressions *) - let map_a = map f_a_before f_a_after f_e in - let map_e = Option.value ~default:(fun x -> x) f_e in - let f_a_before = Option.value ~default:(fun x -> (x, true)) f_a_before in - let f_a_after = Option.value ~default:(fun x -> x) f_a_after in - let a', recurse = f_a_before a in - - if not recurse then a' - else - let a'' = - match a' with - | And (a1, a2) -> And (map_a a1, map_a a2) - | Or (a1, a2) -> Or (map_a a1, map_a a2) - | Impl (a1, a2) -> Impl (map_a a1, map_a a2) - | Not a -> Not (map_a a) - | True -> True - | False -> False - | Eq (e1, e2) -> Eq (map_e e1, map_e e2) - | FLess (e1, e2) -> FLess (map_e e1, map_e e2) - | FLessEq (e1, e2) -> FLessEq (map_e e1, map_e e2) - | ILess (e1, e2) -> ILess (map_e e1, map_e e2) - | ILessEq (e1, e2) -> ILessEq (map_e e1, map_e e2) - | StrLess (e1, e2) -> StrLess (map_e e1, map_e e2) - | SetMem (e1, e2) -> SetMem (map_e e1, map_e e2) - | SetSub (e1, e2) -> SetSub (map_e e1, map_e e2) - | ForAll (bt, a) -> ForAll (bt, map_a a) - | IsInt e -> IsInt (map_e e) - in - f_a_after a'' - -let rec map_opt - (f_a_before : (t -> t option * bool) option) - (f_a_after : (t -> t) option) - (f_e : (Expr.t -> Expr.t option) option) - (a : t) : t option = - (* Map recursively to assertions and expressions *) - let map_a = map_opt f_a_before f_a_after f_e in - let map_e = Option.value ~default:(fun x -> Some x) f_e in - let f_a_before = Option.value ~default:(fun x -> (Some x, true)) f_a_before in - let f_a_after = Option.value ~default:(fun x -> x) f_a_after in - let a', recurse = f_a_before a in - - let aux_a_single a f = - let ma = map_a a in - Option.map f ma - in - - let aux_a_double a1 a2 f = - let ma1, ma2 = (map_a a1, map_a a2) in - if ma1 = None || ma2 = None then None - else Some (f (Option.get ma1) (Option.get ma2)) - in - - let aux_e e1 e2 f = - let me1, me2 = (map_e e1, map_e e2) in - if me1 = None || me2 = None then None - else Some (f (Option.get me1) (Option.get me2)) - in - - match a' with - | None -> None - | Some a' -> - if not recurse then Some a' - else - let a'' = - match a' with - | And (a1, a2) -> aux_a_double a1 a2 (fun a1 a2 -> And (a1, a2)) - | Or (a1, a2) -> aux_a_double a1 a2 (fun a1 a2 -> Or (a1, a2)) - | Impl (a1, a2) -> aux_a_double a1 a2 (fun a1 a2 -> Impl (a1, a2)) - | Not a -> aux_a_single a (fun a -> Not a) - | True -> Some True - | False -> Some False - | Eq (e1, e2) -> aux_e e1 e2 (fun e1 e2 -> Eq (e1, e2)) - | ILess (e1, e2) -> aux_e e1 e2 (fun e1 e2 -> ILess (e1, e2)) - | ILessEq (e1, e2) -> aux_e e1 e2 (fun e1 e2 -> ILessEq (e1, e2)) - | FLess (e1, e2) -> aux_e e1 e2 (fun e1 e2 -> FLess (e1, e2)) - | FLessEq (e1, e2) -> aux_e e1 e2 (fun e1 e2 -> FLessEq (e1, e2)) - | StrLess (e1, e2) -> aux_e e1 e2 (fun e1 e2 -> StrLess (e1, e2)) - | SetMem (e1, e2) -> aux_e e1 e2 (fun e1 e2 -> SetMem (e1, e2)) - | SetSub (e1, e2) -> aux_e e1 e2 (fun e1 e2 -> SetSub (e1, e2)) - | ForAll (bt, a) -> aux_a_single a (fun a -> ForAll (bt, a)) - | IsInt e -> map_e e |> Option.map (fun e -> IsInt e) - in - Option.map f_a_after a'' - -(* Get all the logical variables in --a-- *) -let lvars (f : t) : SS.t = - Visitors.Collectors.lvar_collector#visit_formula SS.empty f - -(* Get all the program variables in --a-- *) -let pvars (f : t) : SS.t = Visitors.Collectors.pvar_collector#visit_formula () f - -(* Get all the abstract locations in --a-- *) -let alocs (f : t) : SS.t = Visitors.Collectors.aloc_collector#visit_formula () f - -(* Get all the concrete locations in [a] *) -let clocs (f : t) : SS.t = Visitors.Collectors.cloc_collector#visit_formula () f - -(* Get all the locations in [a] *) -let locs (f : t) : SS.t = Visitors.Collectors.cloc_collector#visit_formula () f -let get_print_info (a : t) = (pvars a, lvars a, locs a) - -(* Get all the logical expressions of --a-- of the form (Lit (LList lst)) and (EList lst) *) -let lists (f : t) : Expr.t list = - Visitors.Collectors.list_collector#visit_formula () f - -(* Get all the logical expressions of --a-- that denote a list - and are not logical variables *) -let list_lexprs (f : t) : Expr.Set.t = list_lexprs_collector#visit_formula () f - -let rec push_in_negations_off (a : t) : t = - let f_off = push_in_negations_off in - let f_on = push_in_negations_on in - match a with - | And (a1, a2) -> And (f_off a1, f_off a2) - | Or (a1, a2) -> Or (f_off a1, f_off a2) - | Not a1 -> f_on a1 - | ForAll (bt, a) -> ForAll (bt, f_off a) - | _ -> a - -and push_in_negations_on (a : t) : t = - let f_off = push_in_negations_off in - let f_on = push_in_negations_on in - match a with - | And (a1, a2) -> Or (f_on a1, f_on a2) - | Or (a1, a2) -> And (f_on a1, f_on a2) - | True -> False - | False -> True - | Not a -> f_off a - | _ -> Not a - -and push_in_negations (a : t) : t = push_in_negations_off a - -let rec split_conjunct_formulae (f : t) : t list = - match f with - | And (f1, f2) -> split_conjunct_formulae f1 @ split_conjunct_formulae f2 - | Not (Or (f1, f2)) -> split_conjunct_formulae (And (Not f1, Not f2)) - | f -> [ f ] - -(****** Pretty Printing *********) - -(* To avoid code redundancy, we write a pp function parametric on the Expr printing function. - We then instantiate the function with Expr.pp and Expr.full_pp *) -let rec pp_parametric pp_expr fmt f = - let pp_var_with_type fmt (x, t_opt) = - Fmt.pf fmt "%s%a" x - (Fmt.option (fun fm t -> Fmt.pf fm " : %s" (Type.str t))) - t_opt - in - let pp = pp_parametric pp_expr in - match f with - (* a1 /\ a2 *) - | And (a1, a2) -> Fmt.pf fmt "(%a /\\@ %a)" pp a1 pp a2 - (* a1 \/ a2 *) - | Or (a1, a2) -> Fmt.pf fmt "(%a \\/@ %a)" pp a1 pp a2 - (* a1 ==> a2 *) - | Impl (a1, a2) -> Fmt.pf fmt "(%a ==> %a)" pp a1 pp a2 - (* ! a *) - | Not a -> Fmt.pf fmt "(! %a)" pp a - (* true *) - | True -> Fmt.string fmt "True" - (* false *) - | False -> Fmt.string fmt "False" - (* e1 == e2 *) - | Eq (e1, e2) -> Fmt.pf fmt "@[(%a ==@ %a)@]" pp_expr e1 pp_expr e2 - (* e1 <#e2 *) - | FLess (e1, e2) -> Fmt.pf fmt "(%a <# %a)" pp_expr e1 pp_expr e2 - (* e1 <=# e2 *) - | FLessEq (e1, e2) -> Fmt.pf fmt "(%a <=# %a)" pp_expr e1 pp_expr e2 - (* e1 i<# e2 *) - | ILess (e1, e2) -> Fmt.pf fmt "(%a i<# %a)" pp_expr e1 pp_expr e2 - (* e1 i<=# e2 *) - | ILessEq (e1, e2) -> Fmt.pf fmt "(%a i<=# %a)" pp_expr e1 pp_expr e2 - (* e1 Fmt.pf fmt "(%a s<# %a)" pp_expr e1 pp_expr e2 - (* forall vars . a *) - | ForAll (lvars, a) -> - Fmt.pf fmt "(forall %a . %a)" - (Fmt.list ~sep:Fmt.comma pp_var_with_type) - lvars pp a - (* e1 --e-- e2 *) - | SetMem (e1, e2) -> Fmt.pf fmt "(%a --e-- %a)" pp_expr e1 pp_expr e2 - (* e1 --s-- e2 *) - | SetSub (e1, e2) -> Fmt.pf fmt "(%a --s-- %a)" pp_expr e1 pp_expr e2 - | IsInt e -> Fmt.pf fmt "(is_int %a)" pp_expr e - -let pp = pp_parametric Expr.pp -let full_pp = pp_parametric Expr.full_pp - -let rec lift_logic_expr (e : Expr.t) : (t * t) option = - let open Syntaxes.Option in - let f = lift_logic_expr in - match e with - | LVar _ | PVar _ -> Some (Eq (e, Lit (Bool true)), Eq (e, Lit (Bool false))) - | Lit (Bool true) -> Some (True, False) - | Lit (Bool false) -> Some (False, True) - | BinOp (e1, Equal, e2) -> - let a = Eq (e1, e2) in - Some (a, Not a) - | BinOp (e1, FLessThan, e2) -> - let a = FLess (e1, e2) in - Some (a, Not a) - | BinOp (e1, ILessThan, e2) -> - let a = ILess (e1, e2) in - Some (a, Not a) - | BinOp (e1, SLessThan, e2) -> - let a = StrLess (e1, e2) in - Some (a, Not a) - | BinOp (e1, FLessThanEqual, e2) -> - let a = FLessEq (e1, e2) in - Some (a, Not a) - | BinOp (e1, ILessThanEqual, e2) -> - let a = ILessEq (e1, e2) in - Some (a, Not a) - | BinOp (e1, BSetMem, e2) -> - let a = SetMem (e1, e2) in - Some (a, Not a) - | BinOp (e1, BSetSub, e2) -> - let a = SetSub (e1, e2) in - Some (a, Not a) - | BinOp (e1, BAnd, e2) -> - let* a1, na1 = f e1 in - let+ a2, na2 = f e2 in - (And (a1, a2), Or (na1, na2)) - | BinOp (e1, BOr, e2) -> - let* a1, na1 = f e1 in - let+ a2, na2 = f e2 in - (Or (a1, a2), And (na1, na2)) - | BinOp (e1, BImpl, e2) -> - let* a1, _ = f e1 in - let+ a2, na2 = f e2 in - (Impl (a1, a2), And (a1, na2)) - | UnOp (UNot, e') -> - let+ a, na = f e' in - (na, a) - | Exists (bt, inner) as e -> - let+ _, inner_neg = f inner in - let neg = ForAll (bt, inner_neg) in - (Eq (e, Expr.bool true), neg) - | EForall (bt, e) -> - let+ inner, _ = f e in - let pos = ForAll (bt, inner) in - let inner_neg = Expr.Infix.not e in - let neg = Expr.Exists (bt, inner_neg) in - (pos, Eq (neg, Expr.bool true)) - | _ -> None - -let rec to_expr (a : t) : Expr.t option = - let f = to_expr in - match a with - | True -> Some (Expr.Lit (Bool true)) - | False -> Some (Expr.Lit (Bool false)) - | Not a' -> Option.map (fun a -> Expr.UnOp (UnOp.UNot, a)) (f a') - | And (a1, a2) -> ( - match (f a1, f a2) with - | Some le1, Some le2 -> Some (Expr.BinOp (le1, BinOp.BAnd, le2)) - | _ -> None) - | Or (a1, a2) -> ( - match (f a1, f a2) with - | Some le1, Some le2 -> Some (Expr.BinOp (le1, BinOp.BOr, le2)) - | _ -> None) - | Impl (a1, a2) -> ( - match (f (Not a1), f a2) with - | Some e1, Some e2 -> Some (Expr.BinOp (e1, BinOp.BOr, e2)) - | _ -> None) - | ForAll _ -> None - | Eq (le1, le2) -> Some (Expr.BinOp (le1, BinOp.Equal, le2)) - | FLess (le1, le2) -> Some (Expr.BinOp (le1, BinOp.FLessThan, le2)) - | FLessEq (le1, le2) -> Some (Expr.BinOp (le1, BinOp.FLessThanEqual, le2)) - | ILess (le1, le2) -> Some (Expr.BinOp (le1, BinOp.ILessThan, le2)) - | ILessEq (le1, le2) -> Some (Expr.BinOp (le1, BinOp.ILessThanEqual, le2)) - | StrLess (le1, le2) -> Some (Expr.BinOp (le1, BinOp.SLessThan, le2)) - | SetMem (le1, le2) -> Some (Expr.BinOp (le1, BinOp.BSetMem, le2)) - | SetSub (le1, le2) -> Some (Expr.BinOp (le1, BinOp.BSetSub, le2)) - | IsInt e -> - let is_float = Expr.type_eq e Type.NumberType in - let is_whole = - Expr.BinOp (Expr.fmod e (Expr.num 1.), BinOp.Equal, Expr.num 0.) - in - Some (Expr.BinOp (is_float, BinOp.BAnd, is_whole)) - -let rec disjunct (asrts : t list) : t = - match asrts with - | [] -> True - | [ a ] -> a - | a :: r_asrts -> Or (a, disjunct r_asrts) - -let subst_expr_for_expr ~(to_subst : Expr.t) ~(subst_with : Expr.t) (a : t) : t - = - map None None (Some (Expr.subst_expr_for_expr ~to_subst ~subst_with)) a - -let subst_clocs (subst : string -> Expr.t) (f : t) : t = - map None None (Some (Expr.subst_clocs subst)) f - -let rec get_disjuncts (fo : t) : t list = - (* Printf.printf "I am getting disjuncts every day!!\n"; *) - match fo with - | Or (fo1, fo2) -> - (* Printf.printf "More than one disjunct!\n"; *) - get_disjuncts fo1 @ get_disjuncts fo2 - | _ -> [ fo ] - -let strings_and_numbers = - let v = - object - inherit [_] Visitors.reduce - inherit Visitors.Utils.two_list_monoid - method! visit_Num _ n = ([], [ n ]) - method! visit_String _ s = ([ s ], []) - end - in - v#visit_formula () - -module Infix = struct - let fnot a = - match a with - | True -> False - | False -> True - | Not x -> x - | _ -> Not a - - let forall params f = ForAll (params, f) - - let ( #== ) a b = - match (a, b) with - | Expr.Lit la, Expr.Lit lb -> of_bool (Literal.equal la lb) - | a, b when Expr.equal a b -> True - | _ -> Eq (a, b) - - let ( #|| ) a b = - match (a, b) with - | True, _ | _, True -> True - | False, f | f, False -> f - | _ -> Or (a, b) - - let ( #&& ) a b = - match (a, b) with - | True, f | f, True -> f - | False, _ | _, False -> False - | _ -> And (a, b) - - let ( #< ) a b = - match (a, b) with - | Expr.Lit (Int x), Expr.Lit (Int y) -> of_bool (x < y) - | _ -> ILess (a, b) - - let ( #<= ) a b = - match (a, b) with - | Expr.Lit (Int x), Expr.Lit (Int y) -> of_bool (x <= y) - | _ -> ILessEq (a, b) - - let ( #> ) a b = - match (a, b) with - | Expr.Lit (Int x), Expr.Lit (Int y) -> of_bool (x > y) - | _ -> fnot a #<= b - - let ( #>= ) a b = - match (a, b) with - | Expr.Lit (Int x), Expr.Lit (Int y) -> of_bool (x >= y) - | _ -> fnot a #< b - - let ( #<. ) a b = - match (a, b) with - | Expr.Lit (Num x), Expr.Lit (Num y) -> of_bool (x < y) - | _ -> FLess (a, b) - - let ( #<=. ) a b = - match (a, b) with - | Expr.Lit (Num x), Expr.Lit (Num y) -> of_bool (x <= y) - | _ -> FLessEq (a, b) - - let ( #>. ) a b = - match (a, b) with - | Expr.Lit (Num x), Expr.Lit (Num y) -> of_bool (x > y) - | _ -> fnot a #<= b - - let ( #>=. ) a b = - match (a, b) with - | Expr.Lit (Num x), Expr.Lit (Num y) -> of_bool (x >= y) - | _ -> fnot a #< b - - let ( #=> ) fa fb = - match (fa, fb) with - | True, _ -> fb - | False, _ -> True - | _, True -> True - | _, False -> fnot fa - | _ -> Impl (fa, fb) -end - -let pvars_to_lvars (pf : t) : t = - let fe = Expr.pvars_to_lvars in - map None None (Some fe) pf - -let rec conjunct (asrts : t list) : t = - match asrts with - | [] -> True - | [ a ] -> a - | a :: r_asrts -> Infix.( #&& ) a (conjunct r_asrts) diff --git a/GillianCore/GIL_Syntax/Gil_syntax.ml b/GillianCore/GIL_Syntax/Gil_syntax.ml index 8f646982..656d5903 100644 --- a/GillianCore/GIL_Syntax/Gil_syntax.ml +++ b/GillianCore/GIL_Syntax/Gil_syntax.ml @@ -8,7 +8,6 @@ module Cmd = Cmd module Constant = Constant module Expr = Expr module Flag = Flag -module Formula = Formula module LCmd = LCmd module Lemma = Lemma module Literal = Literal diff --git a/GillianCore/GIL_Syntax/Gil_syntax.mli b/GillianCore/GIL_Syntax/Gil_syntax.mli index 5f53533b..f0f02d18 100644 --- a/GillianCore/GIL_Syntax/Gil_syntax.mli +++ b/GillianCore/GIL_Syntax/Gil_syntax.mli @@ -129,7 +129,7 @@ module UnOp : sig type t = | IUnaryMinus (** Integer unary minus *) | FUnaryMinus (** Float unary minus *) - | UNot (** Negation *) + | Not (** Negation *) | BitwiseNot (** Bitwise negation *) | M_isNaN (** Test for NaN *) | M_abs (** Absolute value *) @@ -167,6 +167,7 @@ module UnOp : sig (* Integer vs Number *) | NumToInt (** Number to Integer - actual cast *) | IntToNum (** Integer to Number - actual cast *) + | IsInt (** IsInt e <=> (e : float) /\ (e % 1. == 0) *) [@@deriving yojson, eq] (** Printer *) @@ -193,10 +194,9 @@ module BinOp : sig | FTimes (** Float multiplication *) | FDiv (** Float division *) | FMod (** Float modulus *) - | SLessThan (** Less or equal for strings *) - | BAnd (** Boolean conjunction *) - | BOr (** Boolean disjunction *) - | BImpl (** Boolean implication *) + | And (** Boolean conjunction *) + | Or (** Boolean disjunction *) + | Impl (** Boolean implication *) | BitwiseAnd (** Bitwise conjunction *) | BitwiseOr (** Bitwise disjunction *) | BitwiseXor (** Bitwise exclusive disjunction *) @@ -208,7 +208,7 @@ module BinOp : sig | BitwiseXorL (** Bitwise exclusive disjunction 64bit *) | LeftShiftL (** Left bitshift 64bit *) | SignedRightShiftL (** Signed right bitshift 64bit *) - | UnsignedRightShiftL (** Unsigned right bitshift 64bit *) + | UnsignedRightShiftL (** Right bitshift 64bit *) | BitwiseAndF (** Bitwise conjunction float *) | BitwiseOrF (** Bitwise disjunction float *) | BitwiseXorF (** Bitwise exclusive disjunction float *) @@ -218,12 +218,14 @@ module BinOp : sig | M_atan2 (** Arctangent y/x *) | M_pow (** Power *) | LstNth (** Nth element of a string *) - | LstRepeat (** Nth element of a string *) + | LstRepeat + (* [[a; b]] is the list that contains [b] times the element [a] *) | StrCat (** String concatenation *) | StrNth (** Nth element of a string *) + | StrLess (** Less or equal for strings *) | SetDiff (** Set difference *) - | BSetMem (** Set membership *) - | BSetSub (** Subset *) + | SetMem (** Set membership *) + | SetSub (** Subset *) [@@deriving yojson, eq] (** Printer *) @@ -260,8 +262,8 @@ module Expr : sig | EList of t list (** Lists of expressions *) | ESet of t list (** Sets of expressions *) | Exists of (string * Type.t option) list * t - (** Existential quantification. This is now a circus because the separation between Formula and Expr doesn't make sense anymore. *) - | EForall of (string * Type.t option) list * t + (** Existential quantification. *) + | ForAll of (string * Type.t option) list * t [@@deriving yojson] (** {2: Helpers for building expressions} @@ -318,13 +320,20 @@ module Expr : sig (** {2: } *) - (** Boolean not *) + (** Booleans *) val not : t -> t + val ( && ) : t -> t -> t + val ( || ) : t -> t -> t + val ( ==> ) : t -> t -> t + (** List concatenation *) val ( @+ ) : t -> t -> t end + val conjunct : t list -> t + val disjunct : t list -> t + (** Sets of expressions *) module Set : Set.S with type elt := t @@ -370,6 +379,9 @@ module Expr : sig (** [vars e] returns all variables in [e] (includes lvars, pvars, alocs and clocs) *) val vars : t -> SS.t + (** [push_in_negations e] negates e, recursively *) + val push_in_negations : t -> t + (** [substitutables e] returns all lvars and alocs *) val substitutables : t -> SS.t @@ -409,156 +421,6 @@ module Expr : sig val is_matchable : t -> bool end -(** @canonical Gillian.Gil_syntax.Formula *) -module Formula : sig - (** GIL Formulae *) - - type t = - | True (** Logical true *) - | False (** Logical false *) - | Not of t (** Logical negation *) - | And of t * t (** Logical conjunction *) - | Or of t * t (** Logical disjunction *) - | Eq of Expr.t * Expr.t (** Expression equality *) - | Impl of t * t (** Logical implication *) - | FLess of Expr.t * Expr.t (** Expression less-than for numbers *) - | FLessEq of Expr.t * Expr.t - (** Expression less-than-or-equal for numbers *) - | ILess of Expr.t * Expr.t (** Expression less-than for integers *) - | ILessEq of Expr.t * Expr.t - (** Expression less-than-or-equal for integeres *) - | StrLess of Expr.t * Expr.t (** Expression less-than for strings *) - | SetMem of Expr.t * Expr.t (** Set membership *) - | SetSub of Expr.t * Expr.t (** Set subsetness *) - | ForAll of (string * Type.t option) list * t (** Forall *) - | IsInt of Expr.t (** IsInt e <=> (e : float) /\ (e % 1. == 0) *) - [@@deriving yojson, eq] - - val of_bool : bool -> t - - (** Sets of formulae *) - module Set : Set.S with type elt := t - - (** @deprecated Use {!Visitors.endo} instead *) - val map : - (t -> t * bool) option -> - (t -> t) option -> - (Expr.t -> Expr.t) option -> - t -> - t - - val map_opt : - (t -> t option * bool) option -> - (t -> t) option -> - (Expr.t -> Expr.t option) option -> - t -> - t option - - (** Get all the logical variables*) - val lvars : t -> SS.t - - (** Get all the program variables *) - val pvars : t -> SS.t - - (** Get all the abstract locations *) - val alocs : t -> SS.t - - (** Get all the concrete locations *) - val clocs : t -> SS.t - - (** Get all locations *) - val locs : t -> SS.t - - (** Get print info *) - val get_print_info : t -> SS.t * SS.t * SS.t - - (** Get all the logical expressions of the formula of the form (Lit (LList lst)) and (EList lst) *) - val lists : t -> Expr.t list - - (** Get all the list expressions *) - val list_lexprs : t -> Expr.Set.t - - (** [push_in_negations a] takes negations off the toplevel of [a] and pushes them in the leaves. - For example [push_in_negations (Not (And (True, False)))] returns [Or (False, False)] *) - val push_in_negations : t -> t - - (** Turns [f1 /\ f2 /\ f3] into [\[f1; f2; f3\]] *) - val split_conjunct_formulae : t -> t list - - (** Pretty-printer *) - val pp : Format.formatter -> t -> unit - - (** Pretty-printer with constructors (will not parse) *) - val full_pp : Format.formatter -> t -> unit - - (** Lifts an expression to a formula, if possible. It returns - the lifted expression and its negation *) - val lift_logic_expr : Expr.t -> (t * t) option - - (** Unlifts the formula to an expression, if possible *) - val to_expr : t -> Expr.t option - - (** [conjunct \[a1; ...; an\]] returns [a1 /\ ... /\ an] *) - val conjunct : t list -> t - - (** [disjunct \[a1; ...; an\]] returns [a1 \/ ... \/ an] *) - val disjunct : t list -> t - - val subst_expr_for_expr : to_subst:Expr.t -> subst_with:Expr.t -> t -> t - - (** [subst_clocs subst e] Substitutes expressions of the form [Lit (Loc l)] with [subst l] in [e] *) - val subst_clocs : (string -> Expr.t) -> t -> t - - (** [get_disjuncts (a1 \/ ... \/ an)] returns [\[a1; ...; an\]] *) - val get_disjuncts : t -> t list - - (** Returns a list of strings and a list of numbers that are contained in the formula *) - val strings_and_numbers : t -> string list * float list - - module Infix : sig - (** Same as Not *) - val fnot : t -> t - - (** Same as Forall *) - val forall : (string * Type.t option) list -> t -> t - - (** Same as Or *) - val ( #|| ) : t -> t -> t - - (** Same as And *) - val ( #&& ) : t -> t -> t - - (** Same as Eq *) - val ( #== ) : Expr.t -> Expr.t -> t - - (** Same as ILess *) - val ( #< ) : Expr.t -> Expr.t -> t - - (** [a #> b] if [Not ILess (b, a)]*) - val ( #> ) : Expr.t -> Expr.t -> t - - (** Same as ILessEq *) - val ( #<= ) : Expr.t -> Expr.t -> t - - (** [a #>= b] is [Not ILess (b, a)] *) - val ( #>= ) : Expr.t -> Expr.t -> t - - (** Same as FLess *) - val ( #<. ) : Expr.t -> Expr.t -> t - - (** [a #>. b] if [Not FLess (b, a)]*) - val ( #>. ) : Expr.t -> Expr.t -> t - - (** Same as FLessEq *) - val ( #<=. ) : Expr.t -> Expr.t -> t - - (** [a #>=. b] is [Not FLess (b, a)] *) - val ( #>=. ) : Expr.t -> Expr.t -> t - - val ( #=> ) : t -> t -> t - end -end - (** @canonical Gillian.Gil_syntax.Asrt *) module Asrt : sig (** GIL Assertions *) @@ -566,7 +428,7 @@ module Asrt : sig type atom = | Emp (** Empty heap *) | Pred of string * Expr.t list (** Predicates *) - | Pure of Formula.t (** Pure formula *) + | Pure of Expr.t (** Pure formula *) | Types of (Expr.t * Type.t) list (** Typing assertion *) | CorePred of string * Expr.t list * Expr.t list (** Core assertion *) | Wand of { lhs : string * Expr.t list; rhs : string * Expr.t list } @@ -585,11 +447,7 @@ module Asrt : sig module Set : Set.S with type elt := t (** @deprecated Use {!Visitors.endo} instead *) - val map : (Expr.t -> Expr.t) -> (Formula.t -> Formula.t) -> t -> t - - (** Get all the logical expressions of [a] that denote a list - and are not logical variables *) - val list_lexprs : t -> Expr.Set.t + val map : (Expr.t -> Expr.t) -> t -> t (** Get all the logical variables in [a] *) val lvars : t -> SS.t @@ -610,15 +468,15 @@ module Asrt : sig val pred_names : t -> string list (** Returns a list with the pure assertions that occur in [a] *) - val pure_asrts : t -> Formula.t list + val pure_asrts : t -> Expr.t list (** Check if [a] is a pure assertion *) val is_pure_asrt : atom -> bool - (** Eliminate LStar and LTypes assertions. - LTypes disappears. LStar is replaced by LAnd. - This function expects its argument to be a PURE assertion. *) - val make_pure : t -> Formula.t + (** Eliminate Emp assertions. + Pure assertions are converted to a single formula. + This function expects its argument to be a PURE assertion. *) + val make_pure : t -> Expr.t (** Pretty-printer *) val pp : Format.formatter -> t -> unit @@ -677,21 +535,16 @@ module LCmd : sig type t = | If of Expr.t * t list * t list (** If-then-else *) - | Branch of Formula.t (** Branching on a FO formual *) + | Branch of Expr.t (** Branching on a FO formual *) | Macro of string * Expr.t list (** Macros *) - | Assert of Formula.t (** Assert *) - | Assume of Formula.t (** Assume *) + | Assert of Expr.t (** Assert *) + | Assume of Expr.t (** Assume *) | AssumeType of Expr.t * Type.t (** Assume Type *) | FreshSVar of string (** x := fresh_svar() *) | SL of SLCmd.t (** Separation-logic command *) (** @deprecated Use {!Visitors.endo} instead *) - val map : - (Expr.t -> Expr.t) -> - (Formula.t -> Formula.t) -> - (SLCmd.t -> SLCmd.t) -> - t -> - t + val map : (Expr.t -> Expr.t) -> (SLCmd.t -> SLCmd.t) -> t -> t (** Pretty-printer *) val pp : t Fmt.t @@ -761,7 +614,7 @@ module Pred : sig pred_ins : int list; (** Ins *) pred_definitions : ((string * string list) option * Asrt.t) list; (** Predicate definitions *) - pred_facts : Formula.t list; (** Facts that hold for every definition *) + pred_facts : Expr.t list; (** Facts that hold for every definition *) pred_guard : Asrt.t option; (** Cost for unfolding the predicate *) pred_pure : bool; (** Is the predicate pure? *) pred_abstract : bool; (** Is the predicate abstract? *) @@ -1247,22 +1100,17 @@ module Visitors : sig 'b = < visit_'annot : 'c -> 'd -> 'd ; visit_'label : 'c -> 'f -> 'f ; visit_ALoc : 'c -> Expr.t -> string -> Expr.t - ; visit_And : 'c -> Formula.t -> Formula.t -> Formula.t -> Formula.t - ; visit_Impl : 'c -> Formula.t -> Formula.t -> Formula.t -> Formula.t + ; visit_And : 'c -> BinOp.t -> BinOp.t + ; visit_Impl : 'c -> BinOp.t -> BinOp.t ; visit_Apply : 'c -> 'f Cmd.t -> string -> Expr.t -> 'f option -> 'f Cmd.t ; visit_ApplyLem : 'c -> SLCmd.t -> string -> Expr.t list -> string list -> SLCmd.t ; visit_Arguments : 'c -> 'f Cmd.t -> string -> 'f Cmd.t - ; visit_Assert : 'c -> LCmd.t -> Formula.t -> LCmd.t + ; visit_Assert : 'c -> LCmd.t -> Expr.t -> LCmd.t ; visit_Assignment : 'c -> 'f Cmd.t -> string -> Expr.t -> 'f Cmd.t - ; visit_Assume : 'c -> LCmd.t -> Formula.t -> LCmd.t + ; visit_Assume : 'c -> LCmd.t -> Expr.t -> LCmd.t ; visit_AssumeType : 'c -> LCmd.t -> Expr.t -> Type.t -> LCmd.t - ; visit_BAnd : 'c -> BinOp.t -> BinOp.t - ; visit_BOr : 'c -> BinOp.t -> BinOp.t - ; visit_BImpl : 'c -> BinOp.t -> BinOp.t - ; visit_BSetMem : 'c -> BinOp.t -> BinOp.t - ; visit_BSetSub : 'c -> BinOp.t -> BinOp.t ; visit_BinOp : 'c -> Expr.t -> Expr.t -> BinOp.t -> Expr.t -> Expr.t ; visit_BitwiseAnd : 'c -> BinOp.t -> BinOp.t ; visit_BitwiseAndL : 'c -> BinOp.t -> BinOp.t @@ -1276,7 +1124,7 @@ module Visitors : sig ; visit_BitwiseXorF : 'c -> BinOp.t -> BinOp.t ; visit_Bool : 'c -> Literal.t -> bool -> Literal.t ; visit_BooleanType : 'c -> Type.t -> Type.t - ; visit_Branch : 'c -> LCmd.t -> Formula.t -> LCmd.t + ; visit_Branch : 'c -> LCmd.t -> Expr.t -> LCmd.t ; visit_Bug : 'c -> Flag.t -> Flag.t ; visit_Call : 'c -> @@ -1302,13 +1150,10 @@ module Visitors : sig ; visit_ESet : 'c -> Expr.t -> Expr.t list -> Expr.t ; visit_Exists : 'c -> Expr.t -> (string * Type.t option) list -> Expr.t -> Expr.t - ; visit_EForall : - 'c -> Expr.t -> (string * Type.t option) list -> Expr.t -> Expr.t ; visit_Emp : 'c -> Asrt.atom -> Asrt.atom ; visit_Empty : 'c -> Literal.t -> Literal.t ; visit_EmptyType : 'c -> Type.t -> Type.t ; visit_Epsilon : 'c -> Constant.t -> Constant.t - ; visit_Eq : 'c -> Formula.t -> Expr.t -> Expr.t -> Formula.t ; visit_Equal : 'c -> BinOp.t -> BinOp.t ; visit_Error : 'c -> Flag.t -> Flag.t ; visit_FDiv : 'c -> BinOp.t -> BinOp.t @@ -1316,11 +1161,12 @@ module Visitors : sig ; visit_FLessThanEqual : 'c -> BinOp.t -> BinOp.t ; visit_FMinus : 'c -> BinOp.t -> BinOp.t ; visit_FMod : 'c -> BinOp.t -> BinOp.t + ; visit_ForAll : + 'c -> Expr.t -> (string * Type.t option) list -> Expr.t -> Expr.t ; visit_FPlus : 'c -> BinOp.t -> BinOp.t ; visit_FTimes : 'c -> BinOp.t -> BinOp.t ; visit_FUnaryMinus : 'c -> UnOp.t -> UnOp.t ; visit_Fail : 'c -> 'f Cmd.t -> string -> Expr.t list -> 'f Cmd.t - ; visit_False : 'c -> Formula.t -> Formula.t ; visit_Fold : 'c -> SLCmd.t -> @@ -1328,12 +1174,6 @@ module Visitors : sig Expr.t list -> (string * (string * Expr.t) list) option -> SLCmd.t - ; visit_ForAll : - 'c -> - Formula.t -> - (string * Type.t option) list -> - Formula.t -> - Formula.t ; visit_CorePred : 'c -> Asrt.atom -> @@ -1372,11 +1212,7 @@ module Visitors : sig ; visit_LeftShift : 'c -> BinOp.t -> BinOp.t ; visit_LeftShiftL : 'c -> BinOp.t -> BinOp.t ; visit_LeftShiftF : 'c -> BinOp.t -> BinOp.t - ; visit_FLess : 'c -> Formula.t -> Expr.t -> Expr.t -> Formula.t - ; visit_FLessEq : 'c -> Formula.t -> Expr.t -> Expr.t -> Formula.t - ; visit_ILess : 'c -> Formula.t -> Expr.t -> Expr.t -> Formula.t - ; visit_ILessEq : 'c -> Formula.t -> Expr.t -> Expr.t -> Formula.t - ; visit_IsInt : 'c -> Formula.t -> Expr.t -> Formula.t + ; visit_IsInt : 'c -> UnOp.t -> UnOp.t ; visit_ListType : 'c -> Type.t -> Type.t ; visit_Lit : 'c -> Expr.t -> Literal.t -> Expr.t ; visit_Loc : 'c -> Literal.t -> string -> Literal.t @@ -1413,29 +1249,28 @@ module Visitors : sig ; visit_NoneType : 'c -> Type.t -> Type.t ; visit_Nono : 'c -> Literal.t -> Literal.t ; visit_Normal : 'c -> Flag.t -> Flag.t - ; visit_Not : 'c -> Formula.t -> Formula.t -> Formula.t + ; visit_Not : 'c -> UnOp.t -> UnOp.t ; visit_Null : 'c -> Literal.t -> Literal.t ; visit_NullType : 'c -> Type.t -> Type.t ; visit_Num : 'c -> Literal.t -> float -> Literal.t ; visit_NumberType : 'c -> Type.t -> Type.t ; visit_ObjectType : 'c -> Type.t -> Type.t - ; visit_Or : 'c -> Formula.t -> Formula.t -> Formula.t -> Formula.t + ; visit_Or : 'c -> BinOp.t -> BinOp.t ; visit_PVar : 'c -> Expr.t -> string -> Expr.t ; visit_PhiAssignment : 'c -> 'f Cmd.t -> (string * Expr.t list) list -> 'f Cmd.t ; visit_Pi : 'c -> Constant.t -> Constant.t ; visit_Pred : 'c -> Asrt.atom -> string -> Expr.t list -> Asrt.atom - ; visit_Pure : 'c -> Asrt.atom -> Formula.t -> Asrt.atom + ; visit_Pure : 'c -> Asrt.atom -> Expr.t -> Asrt.atom ; visit_Random : 'c -> Constant.t -> Constant.t ; visit_ReturnError : 'c -> 'f Cmd.t -> 'f Cmd.t ; visit_ReturnNormal : 'c -> 'f Cmd.t -> 'f Cmd.t ; visit_SL : 'c -> LCmd.t -> SLCmd.t -> LCmd.t - ; visit_SLessThan : 'c -> BinOp.t -> BinOp.t ; visit_SepAssert : 'c -> SLCmd.t -> Asrt.t -> string list -> SLCmd.t ; visit_SetDiff : 'c -> BinOp.t -> BinOp.t ; visit_SetInter : 'c -> NOp.t -> NOp.t - ; visit_SetMem : 'c -> Formula.t -> Expr.t -> Expr.t -> Formula.t - ; visit_SetSub : 'c -> Formula.t -> Expr.t -> Expr.t -> Formula.t + ; visit_SetMem : 'c -> BinOp.t -> BinOp.t + ; visit_SetSub : 'c -> BinOp.t -> BinOp.t ; visit_SetToList : 'c -> UnOp.t -> UnOp.t ; visit_SetType : 'c -> Type.t -> Type.t ; visit_SetUnion : 'c -> NOp.t -> NOp.t @@ -1446,9 +1281,10 @@ module Visitors : sig ; visit_FreshSVar : 'c -> LCmd.t -> string -> LCmd.t ; visit_StrCat : 'c -> BinOp.t -> BinOp.t ; visit_StrLen : 'c -> UnOp.t -> UnOp.t + ; visit_StrLess : 'c -> BinOp.t -> BinOp.t ; visit_NumToInt : 'c -> UnOp.t -> UnOp.t ; visit_IntToNum : 'c -> UnOp.t -> UnOp.t - ; visit_StrLess : 'c -> Formula.t -> Expr.t -> Expr.t -> Formula.t + ; visit_StrLess : 'c -> BinOp.t -> BinOp.t ; visit_StrNth : 'c -> BinOp.t -> BinOp.t ; visit_String : 'c -> Literal.t -> string -> Literal.t ; visit_StringType : 'c -> Type.t -> Type.t @@ -1459,12 +1295,10 @@ module Visitors : sig ; visit_ToStringOp : 'c -> UnOp.t -> UnOp.t ; visit_ToUint16Op : 'c -> UnOp.t -> UnOp.t ; visit_ToUint32Op : 'c -> UnOp.t -> UnOp.t - ; visit_True : 'c -> Formula.t -> Formula.t ; visit_Type : 'c -> Literal.t -> Type.t -> Literal.t ; visit_TypeOf : 'c -> UnOp.t -> UnOp.t ; visit_TypeType : 'c -> Type.t -> Type.t ; visit_Types : 'c -> Asrt.atom -> (Expr.t * Type.t) list -> Asrt.atom - ; visit_UNot : 'c -> UnOp.t -> UnOp.t ; visit_UTCTime : 'c -> Constant.t -> Constant.t ; visit_UnOp : 'c -> Expr.t -> UnOp.t -> Expr.t -> Expr.t ; visit_Undefined : 'c -> Literal.t -> Literal.t @@ -1498,7 +1332,6 @@ module Visitors : sig ; visit_constant : 'c -> Constant.t -> Constant.t ; visit_expr : 'c -> Expr.t -> Expr.t ; visit_flag : 'c -> Flag.t -> Flag.t - ; visit_formula : 'c -> Formula.t -> Formula.t ; visit_lcmd : 'c -> LCmd.t -> LCmd.t ; visit_lemma : 'c -> Lemma.t -> Lemma.t ; visit_lemma_spec : 'c -> Lemma.spec -> Lemma.spec @@ -1517,8 +1350,8 @@ module Visitors : sig method visit_'annot : 'c -> 'd -> 'd method visit_'label : 'c -> 'f -> 'f method visit_ALoc : 'c -> Expr.t -> string -> Expr.t - method visit_And : 'c -> Formula.t -> Formula.t -> Formula.t -> Formula.t - method visit_Impl : 'c -> Formula.t -> Formula.t -> Formula.t -> Formula.t + method visit_And : 'c -> BinOp.t -> BinOp.t + method visit_Impl : 'c -> BinOp.t -> BinOp.t method visit_Apply : 'c -> 'f Cmd.t -> string -> Expr.t -> 'f option -> 'f Cmd.t @@ -1527,15 +1360,10 @@ module Visitors : sig 'c -> SLCmd.t -> string -> Expr.t list -> string list -> SLCmd.t method visit_Arguments : 'c -> 'f Cmd.t -> string -> 'f Cmd.t - method visit_Assert : 'c -> LCmd.t -> Formula.t -> LCmd.t + method visit_Assert : 'c -> LCmd.t -> Expr.t -> LCmd.t method visit_Assignment : 'c -> 'f Cmd.t -> string -> Expr.t -> 'f Cmd.t - method visit_Assume : 'c -> LCmd.t -> Formula.t -> LCmd.t + method visit_Assume : 'c -> LCmd.t -> Expr.t -> LCmd.t method visit_AssumeType : 'c -> LCmd.t -> Expr.t -> Type.t -> LCmd.t - method visit_BAnd : 'c -> BinOp.t -> BinOp.t - method visit_BOr : 'c -> BinOp.t -> BinOp.t - method visit_BImpl : 'c -> BinOp.t -> BinOp.t - method visit_BSetMem : 'c -> BinOp.t -> BinOp.t - method visit_BSetSub : 'c -> BinOp.t -> BinOp.t method visit_BinOp : 'c -> Expr.t -> Expr.t -> BinOp.t -> Expr.t -> Expr.t method visit_BitwiseAnd : 'c -> BinOp.t -> BinOp.t method visit_BitwiseAndL : 'c -> BinOp.t -> BinOp.t @@ -1549,7 +1377,7 @@ module Visitors : sig method visit_BitwiseXorF : 'c -> BinOp.t -> BinOp.t method visit_Bool : 'c -> Literal.t -> bool -> Literal.t method visit_BooleanType : 'c -> Type.t -> Type.t - method visit_Branch : 'c -> LCmd.t -> Formula.t -> LCmd.t + method visit_Branch : 'c -> LCmd.t -> Expr.t -> LCmd.t method visit_Bug : 'c -> Flag.t -> Flag.t method visit_Call : @@ -1575,14 +1403,10 @@ module Visitors : sig method visit_Exists : 'c -> Expr.t -> (string * Type.t option) list -> Expr.t -> Expr.t - method visit_EForall : - 'c -> Expr.t -> (string * Type.t option) list -> Expr.t -> Expr.t - method visit_Emp : 'c -> Asrt.atom -> Asrt.atom method visit_Empty : 'c -> Literal.t -> Literal.t method visit_EmptyType : 'c -> Type.t -> Type.t method visit_Epsilon : 'c -> Constant.t -> Constant.t - method visit_Eq : 'c -> Formula.t -> Expr.t -> Expr.t -> Formula.t method visit_Equal : 'c -> BinOp.t -> BinOp.t method visit_Error : 'c -> Flag.t -> Flag.t method visit_FDiv : 'c -> BinOp.t -> BinOp.t @@ -1594,7 +1418,6 @@ module Visitors : sig method visit_FTimes : 'c -> BinOp.t -> BinOp.t method visit_FUnaryMinus : 'c -> UnOp.t -> UnOp.t method visit_Fail : 'c -> 'f Cmd.t -> string -> Expr.t list -> 'f Cmd.t - method visit_False : 'c -> Formula.t -> Formula.t method visit_Fold : 'c -> @@ -1605,7 +1428,7 @@ module Visitors : sig SLCmd.t method visit_ForAll : - 'c -> Formula.t -> (string * Type.t option) list -> Formula.t -> Formula.t + 'c -> Expr.t -> (string * Type.t option) list -> Expr.t -> Expr.t method visit_CorePred : 'c -> Asrt.atom -> string -> Expr.t list -> Expr.t list -> Asrt.atom @@ -1646,11 +1469,7 @@ module Visitors : sig method visit_LeftShift : 'c -> BinOp.t -> BinOp.t method visit_LeftShiftL : 'c -> BinOp.t -> BinOp.t method visit_LeftShiftF : 'c -> BinOp.t -> BinOp.t - method visit_FLess : 'c -> Formula.t -> Expr.t -> Expr.t -> Formula.t - method visit_FLessEq : 'c -> Formula.t -> Expr.t -> Expr.t -> Formula.t - method visit_ILess : 'c -> Formula.t -> Expr.t -> Expr.t -> Formula.t - method visit_ILessEq : 'c -> Formula.t -> Expr.t -> Expr.t -> Formula.t - method visit_IsInt : 'c -> Formula.t -> Expr.t -> Formula.t + method visit_IsInt : 'c -> UnOp.t -> UnOp.t method visit_ListType : 'c -> Type.t -> Type.t method visit_Lit : 'c -> Expr.t -> Literal.t -> Expr.t method visit_Loc : 'c -> Literal.t -> string -> Literal.t @@ -1687,13 +1506,13 @@ module Visitors : sig method visit_NoneType : 'c -> Type.t -> Type.t method visit_Nono : 'c -> Literal.t -> Literal.t method visit_Normal : 'c -> Flag.t -> Flag.t - method visit_Not : 'c -> Formula.t -> Formula.t -> Formula.t + method visit_Not : 'c -> UnOp.t -> UnOp.t method visit_Null : 'c -> Literal.t -> Literal.t method visit_NullType : 'c -> Type.t -> Type.t method visit_Num : 'c -> Literal.t -> float -> Literal.t method visit_NumberType : 'c -> Type.t -> Type.t method visit_ObjectType : 'c -> Type.t -> Type.t - method visit_Or : 'c -> Formula.t -> Formula.t -> Formula.t -> Formula.t + method visit_Or : 'c -> BinOp.t -> BinOp.t method visit_PVar : 'c -> Expr.t -> string -> Expr.t method visit_PhiAssignment : @@ -1701,17 +1520,16 @@ module Visitors : sig method visit_Pi : 'c -> Constant.t -> Constant.t method visit_Pred : 'c -> Asrt.atom -> string -> Expr.t list -> Asrt.atom - method visit_Pure : 'c -> Asrt.atom -> Formula.t -> Asrt.atom + method visit_Pure : 'c -> Asrt.atom -> Expr.t -> Asrt.atom method visit_Random : 'c -> Constant.t -> Constant.t method visit_ReturnError : 'c -> 'f Cmd.t -> 'f Cmd.t method visit_ReturnNormal : 'c -> 'f Cmd.t -> 'f Cmd.t method visit_SL : 'c -> LCmd.t -> SLCmd.t -> LCmd.t - method visit_SLessThan : 'c -> BinOp.t -> BinOp.t method visit_SepAssert : 'c -> SLCmd.t -> Asrt.t -> string list -> SLCmd.t method visit_SetDiff : 'c -> BinOp.t -> BinOp.t method visit_SetInter : 'c -> NOp.t -> NOp.t - method visit_SetMem : 'c -> Formula.t -> Expr.t -> Expr.t -> Formula.t - method visit_SetSub : 'c -> Formula.t -> Expr.t -> Expr.t -> Formula.t + method visit_SetMem : 'c -> BinOp.t -> BinOp.t + method visit_SetSub : 'c -> BinOp.t -> BinOp.t method visit_SetToList : 'c -> UnOp.t -> UnOp.t method visit_SetType : 'c -> Type.t -> Type.t method visit_SetUnion : 'c -> NOp.t -> NOp.t @@ -1722,9 +1540,10 @@ module Visitors : sig method visit_FreshSVar : 'c -> LCmd.t -> string -> LCmd.t method visit_StrCat : 'c -> BinOp.t -> BinOp.t method visit_StrLen : 'c -> UnOp.t -> UnOp.t + method visit_StrLess : 'c -> BinOp.t -> BinOp.t method visit_IntToNum : 'c -> UnOp.t -> UnOp.t method visit_NumToInt : 'c -> UnOp.t -> UnOp.t - method visit_StrLess : 'c -> Formula.t -> Expr.t -> Expr.t -> Formula.t + method visit_StrLess : 'c -> BinOp.t -> BinOp.t method visit_StrNth : 'c -> BinOp.t -> BinOp.t method visit_String : 'c -> Literal.t -> string -> Literal.t method visit_StringType : 'c -> Type.t -> Type.t @@ -1735,12 +1554,10 @@ module Visitors : sig method visit_ToStringOp : 'c -> UnOp.t -> UnOp.t method visit_ToUint16Op : 'c -> UnOp.t -> UnOp.t method visit_ToUint32Op : 'c -> UnOp.t -> UnOp.t - method visit_True : 'c -> Formula.t -> Formula.t method visit_Type : 'c -> Literal.t -> Type.t -> Literal.t method visit_TypeOf : 'c -> UnOp.t -> UnOp.t method visit_TypeType : 'c -> Type.t -> Type.t method visit_Types : 'c -> Asrt.atom -> (Expr.t * Type.t) list -> Asrt.atom - method visit_UNot : 'c -> UnOp.t -> UnOp.t method visit_UTCTime : 'c -> Constant.t -> Constant.t method visit_UnOp : 'c -> Expr.t -> UnOp.t -> Expr.t -> Expr.t method visit_Undefined : 'c -> Literal.t -> Literal.t @@ -1781,7 +1598,6 @@ module Visitors : sig method visit_expr : 'c -> Expr.t -> Expr.t method visit_flag : 'c -> Flag.t -> Flag.t method private visit_float : 'env. 'env -> float -> float - method visit_formula : 'c -> Formula.t -> Formula.t method private visit_int : 'env. 'env -> int -> int method private visit_int32 : 'env. 'env -> int32 -> int32 method private visit_int64 : 'env. 'env -> int64 -> int64 @@ -1832,20 +1648,15 @@ module Visitors : sig 'b = < visit_'annot : 'c -> 'd -> 'f ; visit_'label : 'c -> 'g -> 'f ; visit_ALoc : 'c -> ALoc.t -> 'f - ; visit_And : 'c -> Formula.t -> Formula.t -> 'f - ; visit_Impl : 'c -> Formula.t -> Formula.t -> 'f + ; visit_And : 'c -> 'f + ; visit_Impl : 'c -> 'f ; visit_Apply : 'c -> string -> Expr.t -> 'g option -> 'f ; visit_ApplyLem : 'c -> string -> Expr.t list -> string list -> 'f ; visit_Arguments : 'c -> string -> 'f - ; visit_Assert : 'c -> Formula.t -> 'f + ; visit_Assert : 'c -> Expr.t -> 'f ; visit_Assignment : 'c -> string -> Expr.t -> 'f - ; visit_Assume : 'c -> Formula.t -> 'f + ; visit_Assume : 'c -> Expr.t -> 'f ; visit_AssumeType : 'c -> Expr.t -> Type.t -> 'f - ; visit_BAnd : 'c -> 'f - ; visit_BOr : 'c -> 'f - ; visit_BImpl : 'c -> 'f - ; visit_BSetMem : 'c -> 'f - ; visit_BSetSub : 'c -> 'f ; visit_BinOp : 'c -> Expr.t -> BinOp.t -> Expr.t -> 'f ; visit_BitwiseAnd : 'c -> 'f ; visit_BitwiseAndL : 'c -> 'f @@ -1859,7 +1670,7 @@ module Visitors : sig ; visit_BitwiseXorF : 'c -> 'f ; visit_Bool : 'c -> bool -> 'f ; visit_BooleanType : 'c -> 'f - ; visit_Branch : 'c -> Formula.t -> 'f + ; visit_Branch : 'c -> Expr.t -> 'f ; visit_Bug : 'c -> 'f ; visit_Call : 'c -> @@ -1879,23 +1690,20 @@ module Visitors : sig ; visit_EList : 'c -> Expr.t list -> 'f ; visit_ESet : 'c -> Expr.t list -> 'f ; visit_Exists : 'c -> (string * Type.t option) list -> Expr.t -> 'f - ; visit_EForall : 'c -> (string * Type.t option) list -> Expr.t -> 'f ; visit_Emp : 'c -> 'f ; visit_Empty : 'c -> 'f ; visit_EmptyType : 'c -> 'f ; visit_Epsilon : 'c -> 'f - ; visit_Eq : 'c -> Expr.t -> Expr.t -> 'f ; visit_Equal : 'c -> 'f ; visit_Error : 'c -> 'f ; visit_Fail : 'c -> string -> Expr.t list -> 'f - ; visit_False : 'c -> 'f ; visit_Fold : 'c -> string -> Expr.t list -> (string * (string * Expr.t) list) option -> 'f - ; visit_ForAll : 'c -> (string * Type.t option) list -> Formula.t -> 'f + ; visit_ForAll : 'c -> (string * Type.t option) list -> Expr.t -> 'f ; visit_CorePred : 'c -> string -> Expr.t list -> Expr.t list -> 'f ; visit_Wand : 'c -> string * Expr.t list -> string * Expr.t list -> 'f ; visit_GUnfold : 'c -> string -> 'f @@ -1911,16 +1719,11 @@ module Visitors : sig ; visit_LeftShift : 'c -> 'f ; visit_LeftShiftL : 'c -> 'f ; visit_LeftShiftF : 'c -> 'f - ; visit_FLess : 'c -> Expr.t -> Expr.t -> 'f - ; visit_FLessEq : 'c -> Expr.t -> Expr.t -> 'f - ; visit_ILess : 'c -> Expr.t -> Expr.t -> 'f - ; visit_ILessEq : 'c -> Expr.t -> Expr.t -> 'f - ; visit_IsInt : 'c -> Expr.t -> 'f + ; visit_IsInt : 'c -> 'f ; visit_ILessThan : 'c -> 'f ; visit_ILessThanEqual : 'c -> 'f ; visit_FLessThan : 'c -> 'f ; visit_FLessThanEqual : 'c -> 'f - ; visit_SLessThan : 'c -> 'f ; visit_ListType : 'c -> 'f ; visit_Lit : 'c -> Literal.t -> 'f ; visit_Loc : 'c -> string -> 'f @@ -1961,7 +1764,7 @@ module Visitors : sig ; visit_NoneType : 'c -> 'f ; visit_Nono : 'c -> 'f ; visit_Normal : 'c -> 'f - ; visit_Not : 'c -> Formula.t -> 'f + ; visit_Not : 'c -> 'f ; visit_Null : 'c -> 'f ; visit_NullType : 'c -> 'f ; visit_Int : 'c -> Z.t -> 'f @@ -1969,14 +1772,14 @@ module Visitors : sig ; visit_IntType : 'c -> 'f ; visit_NumberType : 'c -> 'f ; visit_ObjectType : 'c -> 'f - ; visit_Or : 'c -> Formula.t -> Formula.t -> 'f + ; visit_Or : 'c -> 'f ; visit_PVar : 'c -> string -> 'f ; visit_PhiAssignment : 'c -> (string * Expr.t list) list -> 'f ; visit_Pi : 'c -> 'f ; visit_IPlus : 'c -> 'f ; visit_FPlus : 'c -> 'f ; visit_Pred : 'c -> string -> Expr.t list -> 'f - ; visit_Pure : 'c -> Formula.t -> 'f + ; visit_Pure : 'c -> Expr.t -> 'f ; visit_Random : 'c -> 'f ; visit_ReturnError : 'c -> 'f ; visit_ReturnNormal : 'c -> 'f @@ -1984,8 +1787,8 @@ module Visitors : sig ; visit_SepAssert : 'c -> Asrt.t -> string list -> 'f ; visit_SetDiff : 'c -> 'f ; visit_SetInter : 'c -> 'f - ; visit_SetMem : 'c -> Expr.t -> Expr.t -> 'f - ; visit_SetSub : 'c -> Expr.t -> Expr.t -> 'f + ; visit_SetMem : 'c -> 'f + ; visit_SetSub : 'c -> 'f ; visit_SetToList : 'c -> 'f ; visit_SetType : 'c -> 'f ; visit_SetUnion : 'c -> 'f @@ -1996,9 +1799,10 @@ module Visitors : sig ; visit_FreshSVar : 'c -> string -> 'f ; visit_StrCat : 'c -> 'f ; visit_StrLen : 'c -> 'f + ; visit_StrLess : 'c -> 'f ; visit_IntToNum : 'c -> 'f ; visit_NumToInt : 'c -> 'f - ; visit_StrLess : 'c -> Expr.t -> Expr.t -> 'f + ; visit_StrLess : 'c -> 'f ; visit_StrNth : 'c -> 'f ; visit_String : 'c -> string -> 'f ; visit_StringType : 'c -> 'f @@ -2011,12 +1815,10 @@ module Visitors : sig ; visit_ToStringOp : 'c -> 'f ; visit_ToUint16Op : 'c -> 'f ; visit_ToUint32Op : 'c -> 'f - ; visit_True : 'c -> 'f ; visit_Type : 'c -> Type.t -> 'f ; visit_TypeOf : 'c -> 'f ; visit_TypeType : 'c -> 'f ; visit_Types : 'c -> (Expr.t * Type.t) list -> 'f - ; visit_UNot : 'c -> 'f ; visit_UTCTime : 'c -> 'f ; visit_UnOp : 'c -> UnOp.t -> Expr.t -> 'f ; visit_IUnaryMinus : 'c -> 'f @@ -2044,7 +1846,6 @@ module Visitors : sig ; visit_constant : 'c -> Constant.t -> 'f ; visit_expr : 'c -> Expr.t -> 'f ; visit_flag : 'c -> Flag.t -> 'f - ; visit_formula : 'c -> Formula.t -> 'f ; visit_lcmd : 'c -> LCmd.t -> 'f ; visit_lemma : 'c -> Lemma.t -> 'f ; visit_lemma_spec : 'c -> Lemma.spec -> 'f @@ -2064,20 +1865,15 @@ module Visitors : sig method visit_'annot : 'c -> 'd -> 'f method visit_'label : 'c -> 'g -> 'f method visit_ALoc : 'c -> ALoc.t -> 'f - method visit_And : 'c -> Formula.t -> Formula.t -> 'f - method visit_Impl : 'c -> Formula.t -> Formula.t -> 'f + method visit_And : 'c -> 'f + method visit_Impl : 'c -> 'f method visit_Apply : 'c -> string -> Expr.t -> 'g option -> 'f method visit_ApplyLem : 'c -> string -> Expr.t list -> string list -> 'f method visit_Arguments : 'c -> string -> 'f - method visit_Assert : 'c -> Formula.t -> 'f + method visit_Assert : 'c -> Expr.t -> 'f method visit_Assignment : 'c -> string -> Expr.t -> 'f - method visit_Assume : 'c -> Formula.t -> 'f + method visit_Assume : 'c -> Expr.t -> 'f method visit_AssumeType : 'c -> Expr.t -> Type.t -> 'f - method visit_BAnd : 'c -> 'f - method visit_BOr : 'c -> 'f - method visit_BImpl : 'c -> 'f - method visit_BSetMem : 'c -> 'f - method visit_BSetSub : 'c -> 'f method visit_BinOp : 'c -> Expr.t -> BinOp.t -> Expr.t -> 'f method visit_BitwiseAnd : 'c -> 'f method visit_BitwiseAndL : 'c -> 'f @@ -2091,7 +1887,7 @@ module Visitors : sig method visit_BitwiseXorF : 'c -> 'f method visit_Bool : 'c -> bool -> 'f method visit_BooleanType : 'c -> 'f - method visit_Branch : 'c -> Formula.t -> 'f + method visit_Branch : 'c -> Expr.t -> 'f method visit_Bug : 'c -> 'f method visit_Call : @@ -2115,16 +1911,13 @@ module Visitors : sig method visit_EList : 'c -> Expr.t list -> 'f method visit_ESet : 'c -> Expr.t list -> 'f method visit_Exists : 'c -> (string * Type.t option) list -> Expr.t -> 'f - method visit_EForall : 'c -> (string * Type.t option) list -> Expr.t -> 'f method visit_Emp : 'c -> 'f method visit_Empty : 'c -> 'f method visit_EmptyType : 'c -> 'f method visit_Epsilon : 'c -> 'f - method visit_Eq : 'c -> Expr.t -> Expr.t -> 'f method visit_Equal : 'c -> 'f method visit_Error : 'c -> 'f method visit_Fail : 'c -> string -> Expr.t list -> 'f - method visit_False : 'c -> 'f method visit_Fold : 'c -> @@ -2133,13 +1926,14 @@ module Visitors : sig (string * (string * Expr.t) list) option -> 'f - method visit_ForAll : 'c -> (string * Type.t option) list -> Formula.t -> 'f + method visit_ForAll : 'c -> (string * Type.t option) list -> Expr.t -> 'f method visit_CorePred : 'c -> string -> Expr.t list -> Expr.t list -> 'f method visit_Wand : 'c -> string * Expr.t list -> string * Expr.t list -> 'f method visit_GUnfold : 'c -> string -> 'f method visit_Goto : 'c -> 'g -> 'f method visit_GuardedGoto : 'c -> Expr.t -> 'g -> 'g -> 'f method visit_If : 'c -> Expr.t -> LCmd.t list -> LCmd.t list -> 'f + method visit_IsInt : 'c -> 'f method visit_Invariant : 'c -> Asrt.t -> string list -> 'f method visit_Consume : 'c -> Asrt.t -> string list -> 'f method visit_Produce : 'c -> Asrt.t -> 'f @@ -2149,16 +1943,10 @@ module Visitors : sig method visit_LeftShift : 'c -> 'f method visit_LeftShiftL : 'c -> 'f method visit_LeftShiftF : 'c -> 'f - method visit_FLess : 'c -> Expr.t -> Expr.t -> 'f - method visit_FLessEq : 'c -> Expr.t -> Expr.t -> 'f - method visit_ILess : 'c -> Expr.t -> Expr.t -> 'f - method visit_ILessEq : 'c -> Expr.t -> Expr.t -> 'f - method visit_IsInt : 'c -> Expr.t -> 'f method visit_ILessThan : 'c -> 'f method visit_ILessThanEqual : 'c -> 'f method visit_FLessThan : 'c -> 'f method visit_FLessThanEqual : 'c -> 'f - method visit_SLessThan : 'c -> 'f method visit_ListType : 'c -> 'f method visit_Lit : 'c -> Literal.t -> 'f method visit_Loc : 'c -> string -> 'f @@ -2199,7 +1987,7 @@ module Visitors : sig method visit_NoneType : 'c -> 'f method visit_Nono : 'c -> 'f method visit_Normal : 'c -> 'f - method visit_Not : 'c -> Formula.t -> 'f + method visit_Not : 'c -> 'f method visit_Null : 'c -> 'f method visit_NullType : 'c -> 'f method visit_Int : 'c -> Z.t -> 'f @@ -2207,14 +1995,14 @@ module Visitors : sig method visit_IntType : 'c -> 'f method visit_NumberType : 'c -> 'f method visit_ObjectType : 'c -> 'f - method visit_Or : 'c -> Formula.t -> Formula.t -> 'f + method visit_Or : 'c -> 'f method visit_PVar : 'c -> string -> 'f method visit_PhiAssignment : 'c -> (string * Expr.t list) list -> 'f method visit_Pi : 'c -> 'f method visit_IPlus : 'c -> 'f method visit_FPlus : 'c -> 'f method visit_Pred : 'c -> string -> Expr.t list -> 'f - method visit_Pure : 'c -> Formula.t -> 'f + method visit_Pure : 'c -> Expr.t -> 'f method visit_Random : 'c -> 'f method visit_ReturnError : 'c -> 'f method visit_ReturnNormal : 'c -> 'f @@ -2222,8 +2010,8 @@ module Visitors : sig method visit_SepAssert : 'c -> Asrt.t -> string list -> 'f method visit_SetDiff : 'c -> 'f method visit_SetInter : 'c -> 'f - method visit_SetMem : 'c -> Expr.t -> Expr.t -> 'f - method visit_SetSub : 'c -> Expr.t -> Expr.t -> 'f + method visit_SetMem : 'c -> 'f + method visit_SetSub : 'c -> 'f method visit_SetToList : 'c -> 'f method visit_SetType : 'c -> 'f method visit_SetUnion : 'c -> 'f @@ -2234,9 +2022,10 @@ module Visitors : sig method visit_FreshSVar : 'c -> string -> 'f method visit_StrCat : 'c -> 'f method visit_StrLen : 'c -> 'f + method visit_StrLess : 'c -> 'f method visit_IntToNum : 'c -> 'f method visit_NumToInt : 'c -> 'f - method visit_StrLess : 'c -> Expr.t -> Expr.t -> 'f + method visit_StrLess : 'c -> 'f method visit_StrNth : 'c -> 'f method visit_String : 'c -> string -> 'f method visit_StringType : 'c -> 'f @@ -2249,12 +2038,10 @@ module Visitors : sig method visit_ToStringOp : 'c -> 'f method visit_ToUint16Op : 'c -> 'f method visit_ToUint32Op : 'c -> 'f - method visit_True : 'c -> 'f method visit_Type : 'c -> Type.t -> 'f method visit_TypeOf : 'c -> 'f method visit_TypeType : 'c -> 'f method visit_Types : 'c -> (Expr.t * Type.t) list -> 'f - method visit_UNot : 'c -> 'f method visit_UTCTime : 'c -> 'f method visit_UnOp : 'c -> UnOp.t -> Expr.t -> 'f method visit_IUnaryMinus : 'c -> 'f @@ -2280,7 +2067,6 @@ module Visitors : sig method visit_constant : 'c -> Constant.t -> 'f method visit_expr : 'c -> Expr.t -> 'f method visit_flag : 'c -> Flag.t -> 'f - method visit_formula : 'c -> Formula.t -> 'f method visit_lcmd : 'c -> LCmd.t -> 'f method visit_lemma : 'c -> Lemma.t -> 'f method visit_lemma_spec : 'c -> Lemma.spec -> 'f @@ -2302,20 +2088,15 @@ module Visitors : sig 'b = < visit_'annot : 'c -> 'd -> unit ; visit_'label : 'c -> 'f -> unit ; visit_ALoc : 'c -> string -> unit - ; visit_And : 'c -> Formula.t -> Formula.t -> unit - ; visit_Impl : 'c -> Formula.t -> Formula.t -> unit + ; visit_And : 'c -> unit + ; visit_Impl : 'c -> unit ; visit_Apply : 'c -> string -> Expr.t -> 'f option -> unit ; visit_ApplyLem : 'c -> string -> Expr.t list -> string list -> unit ; visit_Arguments : 'c -> string -> unit - ; visit_Assert : 'c -> Formula.t -> unit + ; visit_Assert : 'c -> Expr.t -> unit ; visit_Assignment : 'c -> string -> Expr.t -> unit - ; visit_Assume : 'c -> Formula.t -> unit + ; visit_Assume : 'c -> Expr.t -> unit ; visit_AssumeType : 'c -> Expr.t -> Type.t -> unit - ; visit_BAnd : 'c -> unit - ; visit_BOr : 'c -> unit - ; visit_BImpl : 'c -> unit - ; visit_BSetMem : 'c -> unit - ; visit_BSetSub : 'c -> unit ; visit_BinOp : 'c -> Expr.t -> BinOp.t -> Expr.t -> unit ; visit_BitwiseAnd : 'c -> unit ; visit_BitwiseAndL : 'c -> unit @@ -2329,7 +2110,7 @@ module Visitors : sig ; visit_BitwiseXorF : 'c -> unit ; visit_Bool : 'c -> bool -> unit ; visit_BooleanType : 'c -> unit - ; visit_Branch : 'c -> Formula.t -> unit + ; visit_Branch : 'c -> Expr.t -> unit ; visit_Bug : 'c -> unit ; visit_Call : 'c -> @@ -2347,12 +2128,10 @@ module Visitors : sig ; visit_EList : 'c -> Expr.t list -> unit ; visit_ESet : 'c -> Expr.t list -> unit ; visit_Exists : 'c -> (string * Type.t option) list -> Expr.t -> unit - ; visit_EForall : 'c -> (string * Type.t option) list -> Expr.t -> unit ; visit_Emp : 'c -> unit ; visit_Empty : 'c -> unit ; visit_EmptyType : 'c -> unit ; visit_Epsilon : 'c -> unit - ; visit_Eq : 'c -> Expr.t -> Expr.t -> unit ; visit_Equal : 'c -> unit ; visit_Error : 'c -> unit ; visit_FDiv : 'c -> unit @@ -2364,15 +2143,13 @@ module Visitors : sig ; visit_FTimes : 'c -> unit ; visit_FUnaryMinus : 'c -> unit ; visit_Fail : 'c -> string -> Expr.t list -> unit - ; visit_False : 'c -> unit ; visit_Fold : 'c -> string -> Expr.t list -> (string * (string * Expr.t) list) option -> unit - ; visit_ForAll : - 'c -> (string * Type.t option) list -> Formula.t -> unit + ; visit_ForAll : 'c -> (string * Type.t option) list -> Expr.t -> unit ; visit_CorePred : 'c -> string -> Expr.t list -> Expr.t list -> unit ; visit_Wand : 'c -> string * Expr.t list -> string * Expr.t list -> unit @@ -2399,11 +2176,7 @@ module Visitors : sig ; visit_LeftShift : 'c -> unit ; visit_LeftShiftL : 'c -> unit ; visit_LeftShiftF : 'c -> unit - ; visit_FLess : 'c -> Expr.t -> Expr.t -> unit - ; visit_FLessEq : 'c -> Expr.t -> Expr.t -> unit - ; visit_ILess : 'c -> Expr.t -> Expr.t -> unit - ; visit_ILessEq : 'c -> Expr.t -> Expr.t -> unit - ; visit_IsInt : 'c -> Expr.t -> unit + ; visit_IsInt : 'c -> unit ; visit_ListType : 'c -> unit ; visit_Lit : 'c -> Literal.t -> unit ; visit_Loc : 'c -> string -> unit @@ -2440,28 +2213,27 @@ module Visitors : sig ; visit_NoneType : 'c -> unit ; visit_Nono : 'c -> unit ; visit_Normal : 'c -> unit - ; visit_Not : 'c -> Formula.t -> unit + ; visit_Not : 'c -> unit ; visit_Null : 'c -> unit ; visit_NullType : 'c -> unit ; visit_Num : 'c -> float -> unit ; visit_NumberType : 'c -> unit ; visit_ObjectType : 'c -> unit - ; visit_Or : 'c -> Formula.t -> Formula.t -> unit + ; visit_Or : 'c -> unit ; visit_PVar : 'c -> string -> unit ; visit_PhiAssignment : 'c -> (string * Expr.t list) list -> unit ; visit_Pi : 'c -> unit ; visit_Pred : 'c -> string -> Expr.t list -> unit - ; visit_Pure : 'c -> Formula.t -> unit + ; visit_Pure : 'c -> Expr.t -> unit ; visit_Random : 'c -> unit ; visit_ReturnError : 'c -> unit ; visit_ReturnNormal : 'c -> unit ; visit_SL : 'c -> SLCmd.t -> unit - ; visit_SLessThan : 'c -> unit ; visit_SepAssert : 'c -> Asrt.t -> string list -> unit ; visit_SetDiff : 'c -> unit ; visit_SetInter : 'c -> unit - ; visit_SetMem : 'c -> Expr.t -> Expr.t -> unit - ; visit_SetSub : 'c -> Expr.t -> Expr.t -> unit + ; visit_SetMem : 'c -> unit + ; visit_SetSub : 'c -> unit ; visit_SetToList : 'c -> unit ; visit_SetType : 'c -> unit ; visit_SetUnion : 'c -> unit @@ -2472,9 +2244,9 @@ module Visitors : sig ; visit_FreshSVar : 'c -> string -> unit ; visit_StrCat : 'c -> unit ; visit_StrLen : 'c -> unit + ; visit_StrLess : 'c -> unit ; visit_IntToNum : 'c -> unit ; visit_NumToInt : 'c -> unit - ; visit_StrLess : 'c -> Expr.t -> Expr.t -> unit ; visit_StrNth : 'c -> unit ; visit_String : 'c -> string -> unit ; visit_StringType : 'c -> unit @@ -2485,12 +2257,10 @@ module Visitors : sig ; visit_ToStringOp : 'c -> unit ; visit_ToUint16Op : 'c -> unit ; visit_ToUint32Op : 'c -> unit - ; visit_True : 'c -> unit ; visit_Type : 'c -> Type.t -> unit ; visit_TypeOf : 'c -> unit ; visit_TypeType : 'c -> unit ; visit_Types : 'c -> (Expr.t * Type.t) list -> unit - ; visit_UNot : 'c -> unit ; visit_UTCTime : 'c -> unit ; visit_UnOp : 'c -> UnOp.t -> Expr.t -> unit ; visit_Undefined : 'c -> unit @@ -2516,7 +2286,6 @@ module Visitors : sig ; visit_constant : 'c -> Constant.t -> unit ; visit_expr : 'c -> Expr.t -> unit ; visit_flag : 'c -> Flag.t -> unit - ; visit_formula : 'c -> Formula.t -> unit ; visit_lcmd : 'c -> LCmd.t -> unit ; visit_lemma : 'c -> Lemma.t -> unit ; visit_lemma_spec : 'c -> Lemma.spec -> unit @@ -2535,20 +2304,15 @@ module Visitors : sig method visit_'annot : 'c -> 'd -> unit method visit_'label : 'c -> 'f -> unit method visit_ALoc : 'c -> string -> unit - method visit_And : 'c -> Formula.t -> Formula.t -> unit - method visit_Impl : 'c -> Formula.t -> Formula.t -> unit + method visit_And : 'c -> unit + method visit_Impl : 'c -> unit method visit_Apply : 'c -> string -> Expr.t -> 'f option -> unit method visit_ApplyLem : 'c -> string -> Expr.t list -> string list -> unit method visit_Arguments : 'c -> string -> unit - method visit_Assert : 'c -> Formula.t -> unit + method visit_Assert : 'c -> Expr.t -> unit method visit_Assignment : 'c -> string -> Expr.t -> unit - method visit_Assume : 'c -> Formula.t -> unit + method visit_Assume : 'c -> Expr.t -> unit method visit_AssumeType : 'c -> Expr.t -> Type.t -> unit - method visit_BAnd : 'c -> unit - method visit_BOr : 'c -> unit - method visit_BImpl : 'c -> unit - method visit_BSetMem : 'c -> unit - method visit_BSetSub : 'c -> unit method visit_BinOp : 'c -> Expr.t -> BinOp.t -> Expr.t -> unit method visit_BitwiseAnd : 'c -> unit method visit_BitwiseAndL : 'c -> unit @@ -2562,7 +2326,7 @@ module Visitors : sig method visit_BitwiseXorF : 'c -> unit method visit_Bool : 'c -> bool -> unit method visit_BooleanType : 'c -> unit - method visit_Branch : 'c -> Formula.t -> unit + method visit_Branch : 'c -> Expr.t -> unit method visit_Bug : 'c -> unit method visit_Call : @@ -2584,12 +2348,10 @@ module Visitors : sig method visit_EList : 'c -> Expr.t list -> unit method visit_ESet : 'c -> Expr.t list -> unit method visit_Exists : 'c -> (string * Type.t option) list -> Expr.t -> unit - method visit_EForall : 'c -> (string * Type.t option) list -> Expr.t -> unit method visit_Emp : 'c -> unit method visit_Empty : 'c -> unit method visit_EmptyType : 'c -> unit method visit_Epsilon : 'c -> unit - method visit_Eq : 'c -> Expr.t -> Expr.t -> unit method visit_Equal : 'c -> unit method visit_Error : 'c -> unit method visit_FDiv : 'c -> unit @@ -2601,7 +2363,6 @@ module Visitors : sig method visit_FTimes : 'c -> unit method visit_FUnaryMinus : 'c -> unit method visit_Fail : 'c -> string -> Expr.t list -> unit - method visit_False : 'c -> unit method visit_Fold : 'c -> @@ -2610,9 +2371,7 @@ module Visitors : sig (string * (string * Expr.t) list) option -> unit - method visit_ForAll : - 'c -> (string * Type.t option) list -> Formula.t -> unit - + method visit_ForAll : 'c -> (string * Type.t option) list -> Expr.t -> unit method visit_CorePred : 'c -> string -> Expr.t list -> Expr.t list -> unit method visit_Wand : @@ -2641,11 +2400,7 @@ module Visitors : sig method visit_LeftShift : 'c -> unit method visit_LeftShiftL : 'c -> unit method visit_LeftShiftF : 'c -> unit - method visit_FLess : 'c -> Expr.t -> Expr.t -> unit - method visit_FLessEq : 'c -> Expr.t -> Expr.t -> unit - method visit_ILess : 'c -> Expr.t -> Expr.t -> unit - method visit_ILessEq : 'c -> Expr.t -> Expr.t -> unit - method visit_IsInt : 'c -> Expr.t -> unit + method visit_IsInt : 'c -> unit method visit_ListType : 'c -> unit method visit_Lit : 'c -> Literal.t -> unit method visit_Loc : 'c -> string -> unit @@ -2682,28 +2437,27 @@ module Visitors : sig method visit_NoneType : 'c -> unit method visit_Nono : 'c -> unit method visit_Normal : 'c -> unit - method visit_Not : 'c -> Formula.t -> unit + method visit_Not : 'c -> unit method visit_Null : 'c -> unit method visit_NullType : 'c -> unit method visit_Num : 'c -> float -> unit method visit_NumberType : 'c -> unit method visit_ObjectType : 'c -> unit - method visit_Or : 'c -> Formula.t -> Formula.t -> unit + method visit_Or : 'c -> unit method visit_PVar : 'c -> string -> unit method visit_PhiAssignment : 'c -> (string * Expr.t list) list -> unit method visit_Pi : 'c -> unit method visit_Pred : 'c -> string -> Expr.t list -> unit - method visit_Pure : 'c -> Formula.t -> unit + method visit_Pure : 'c -> Expr.t -> unit method visit_Random : 'c -> unit method visit_ReturnError : 'c -> unit method visit_ReturnNormal : 'c -> unit method visit_SL : 'c -> SLCmd.t -> unit - method visit_SLessThan : 'c -> unit method visit_SepAssert : 'c -> Asrt.t -> string list -> unit method visit_SetDiff : 'c -> unit method visit_SetInter : 'c -> unit - method visit_SetMem : 'c -> Expr.t -> Expr.t -> unit - method visit_SetSub : 'c -> Expr.t -> Expr.t -> unit + method visit_SetMem : 'c -> unit + method visit_SetSub : 'c -> unit method visit_SetToList : 'c -> unit method visit_SetType : 'c -> unit method visit_SetUnion : 'c -> unit @@ -2714,9 +2468,9 @@ module Visitors : sig method visit_FreshSVar : 'c -> string -> unit method visit_StrCat : 'c -> unit method visit_StrLen : 'c -> unit + method visit_StrLess : 'c -> unit method visit_IntToNum : 'c -> unit method visit_NumToInt : 'c -> unit - method visit_StrLess : 'c -> Expr.t -> Expr.t -> unit method visit_StrNth : 'c -> unit method visit_String : 'c -> string -> unit method visit_StringType : 'c -> unit @@ -2727,12 +2481,10 @@ module Visitors : sig method visit_ToStringOp : 'c -> unit method visit_ToUint16Op : 'c -> unit method visit_ToUint32Op : 'c -> unit - method visit_True : 'c -> unit method visit_Type : 'c -> Type.t -> unit method visit_TypeOf : 'c -> unit method visit_TypeType : 'c -> unit method visit_Types : 'c -> (Expr.t * Type.t) list -> unit - method visit_UNot : 'c -> unit method visit_UTCTime : 'c -> unit method visit_UnOp : 'c -> UnOp.t -> Expr.t -> unit method visit_Undefined : 'c -> unit @@ -2769,7 +2521,6 @@ module Visitors : sig method visit_expr : 'c -> Expr.t -> unit method visit_flag : 'c -> Flag.t -> unit method private visit_float : 'env. 'env -> float -> unit - method visit_formula : 'c -> Formula.t -> unit method private visit_int : 'env. 'env -> int -> unit method private visit_int32 : 'env. 'env -> int32 -> unit method private visit_int64 : 'env. 'env -> int64 -> unit diff --git a/GillianCore/GIL_Syntax/LCmd.ml b/GillianCore/GIL_Syntax/LCmd.ml index f92a17a2..fd9bff41 100644 --- a/GillianCore/GIL_Syntax/LCmd.ml +++ b/GillianCore/GIL_Syntax/LCmd.ml @@ -4,27 +4,23 @@ module SS = Containers.SS type t = TypeDef__.lcmd = | If of Expr.t * t list * t list (** If-then-else *) - | Branch of Formula.t (** branching on a FO formual *) + | Branch of Expr.t (** branching on a FO formual *) | Macro of string * Expr.t list (** Macro *) - | Assert of Formula.t (** Assert *) - | Assume of Formula.t (** Assume *) + | Assert of Expr.t (** Assert *) + | Assume of Expr.t (** Assume *) | AssumeType of Expr.t * Type.t (** Assume Type *) | FreshSVar of string (** x := fresh_svar() *) | SL of SLCmd.t [@@deriving yojson] -let rec map - (f_e : Expr.t -> Expr.t) - (f_p : Formula.t -> Formula.t) - (f_sl : SLCmd.t -> SLCmd.t) - (lcmd : t) = - let f = map f_e f_p f_sl in +let rec map (f_e : Expr.t -> Expr.t) (f_sl : SLCmd.t -> SLCmd.t) (lcmd : t) = + let f = map f_e f_sl in match lcmd with - | Branch a -> Branch (f_p a) + | Branch a -> Branch (f_e a) | If (e, l1, l2) -> If (f_e e, List.map f l1, List.map f l2) | Macro (s, l) -> Macro (s, List.map f_e l) - | Assume a -> Assume (f_p a) - | Assert a -> Assert (f_p a) + | Assume a -> Assume (f_e a) + | Assert a -> Assert (f_e a) | AssumeType (e, t) -> AssumeType (f_e e, t) | FreshSVar _ as lcmd -> lcmd | SL sl_cmd -> SL (f_sl sl_cmd) @@ -38,8 +34,7 @@ let rec pvars (lcmd : t) : SS.t = | If (e, lthen, lelse) -> SS.union (Expr.pvars e) (SS.union (pvars_lcmds lthen) (pvars_lcmds lelse)) | Macro (_, es) -> pvars_es es - | Branch pf | Assert pf | Assume pf -> Formula.pvars pf - | AssumeType (e, _) -> Expr.pvars e + | Branch e | Assert e | Assume e | AssumeType (e, _) -> Expr.pvars e | FreshSVar name -> SS.singleton name | SL slcmd -> SLCmd.pvars slcmd @@ -50,8 +45,7 @@ let rec lvars (lcmd : t) : SS.t = | If (e, lthen, lelse) -> SS.union (Expr.lvars e) (SS.union (lvars_lcmds lthen) (lvars_lcmds lelse)) | Macro (_, es) -> lvars_es es - | Branch pf | Assert pf | Assume pf -> Formula.lvars pf - | AssumeType (e, _) -> Expr.lvars e + | Branch e | Assert e | Assume e | AssumeType (e, _) -> Expr.lvars e | SL slcmd -> SLCmd.lvars slcmd | FreshSVar _ -> SS.empty @@ -62,8 +56,7 @@ let rec locs (lcmd : t) : SS.t = | If (e, lthen, lelse) -> SS.union (Expr.locs e) (SS.union (locs_lcmds lthen) (locs_lcmds lelse)) | Macro (_, es) -> locs_es es - | Branch pf | Assert pf | Assume pf -> Formula.locs pf - | AssumeType (e, _) -> Expr.locs e + | Branch e | Assert e | Assume e | AssumeType (e, _) -> Expr.locs e | SL slcmd -> SLCmd.locs slcmd | FreshSVar _ -> SS.empty @@ -78,10 +71,10 @@ let rec pp fmt lcmd = else Fmt.pf fmt "if (@[%a@]) @[then {@\n%a@]@\n}" Expr.pp le pp_list then_lcmds - | Branch fo -> Fmt.pf fmt "branch (%a)" Formula.pp fo + | Branch fo -> Fmt.pf fmt "branch (%a)" Expr.pp fo | Macro (name, lparams) -> Fmt.pf fmt "%s(@[%a@])" name pp_params lparams - | Assert a -> Fmt.pf fmt "assert (@[%a@])" Formula.pp a - | Assume a -> Fmt.pf fmt "assume (@[%a@])" Formula.pp a + | Assert a -> Fmt.pf fmt "assert (@[%a@])" Expr.pp a + | Assume a -> Fmt.pf fmt "assume (@[%a@])" Expr.pp a | AssumeType (e, t) -> Fmt.pf fmt "assume_type (%a, %s)" Expr.pp e (Type.str t) | SL sl_cmd -> SLCmd.pp fmt sl_cmd diff --git a/GillianCore/GIL_Syntax/Lemma.ml b/GillianCore/GIL_Syntax/Lemma.ml index de8f19e1..5d88ba38 100644 --- a/GillianCore/GIL_Syntax/Lemma.ml +++ b/GillianCore/GIL_Syntax/Lemma.ml @@ -64,7 +64,7 @@ let add_param_bindings (lemma : t) = let lvar_params = List.map (fun x -> "#" ^ x) params in let param_eqs = List.map2 - (fun pv lv -> Asrt.Pure (Eq (PVar pv, LVar lv))) + (fun pv lv -> Asrt.Pure (Expr.BinOp (PVar pv, Equal, LVar lv))) params lvar_params in let add_to_spec spec = { spec with lemma_hyp = param_eqs @ spec.lemma_hyp } in diff --git a/GillianCore/GIL_Syntax/Pred.ml b/GillianCore/GIL_Syntax/Pred.ml index a8230fa3..50fad6ce 100644 --- a/GillianCore/GIL_Syntax/Pred.ml +++ b/GillianCore/GIL_Syntax/Pred.ml @@ -7,7 +7,7 @@ type t = TypeDef__.pred = { pred_ins : int list; (** Ins *) pred_definitions : ((string * string list) option * Asrt.t) list; (** Predicate definitions *) - pred_facts : Formula.t list; (** Facts that hold for every definition *) + pred_facts : Expr.t list; (** Facts that hold for every definition *) pred_guard : Asrt.t option; (** Cost for unfolding the predicate *) pred_pure : bool; (** Is the predicate pure *) pred_abstract : bool; (** Is the predicate abstract *) @@ -113,9 +113,7 @@ let pp fmt pred = let pp_facts fmt = function | [] -> () | facts -> - Fmt.pf fmt "facts: %a;@\n" - Fmt.(list ~sep:(any " and ") Formula.pp) - facts + Fmt.pf fmt "facts: %a;@\n" Fmt.(list ~sep:(any " and ") Expr.pp) facts in let pp_guard fmt = function | None -> () @@ -238,7 +236,8 @@ let explicit_param_types (preds : (string, t) Hashtbl.t) (pred : t) : t = match t_x with | None -> new_facts | Some t_x -> - Formula.Eq (UnOp (TypeOf, PVar x), Lit (Type t_x)) :: new_facts) + Expr.BinOp (UnOp (TypeOf, PVar x), Equal, Lit (Type t_x)) + :: new_facts) pred.pred_params [] in { diff --git a/GillianCore/GIL_Syntax/TypeDef__.ml b/GillianCore/GIL_Syntax/TypeDef__.ml index 1f53f52b..17ad7776 100644 --- a/GillianCore/GIL_Syntax/TypeDef__.ml +++ b/GillianCore/GIL_Syntax/TypeDef__.ml @@ -60,10 +60,9 @@ and binop = | FTimes | FDiv | FMod - | SLessThan - | BAnd - | BOr - | BImpl + | And + | Or + | Impl | BitwiseAnd | BitwiseOr | BitwiseXor @@ -88,14 +87,15 @@ and binop = | LstRepeat | StrCat | StrNth + | StrLess | SetDiff - | BSetMem - | BSetSub + | SetMem + | SetSub and unop = | IUnaryMinus | FUnaryMinus - | UNot + | Not | BitwiseNot | M_isNaN | M_abs @@ -127,6 +127,7 @@ and unop = | StrLen | NumToInt | IntToNum + | IsInt and nop = LstCat | SetUnion | SetInter @@ -142,30 +143,12 @@ and expr = | EList of expr list | ESet of expr list | Exists of (string * typ option) list * expr - | EForall of (string * typ option) list * expr - -and formula = - | True - | False - | Not of formula - | And of formula * formula - | Or of formula * formula - | Eq of expr * expr - | Impl of formula * formula - | FLess of expr * expr - | FLessEq of expr * expr - | ILess of expr * expr - | ILessEq of expr * expr - | StrLess of expr * expr - | SetMem of expr * expr - | SetSub of expr * expr - | ForAll of (string * typ option) list * formula - | IsInt of expr + | ForAll of (string * typ option) list * expr and assertion_atom = | Emp | Pred of string * expr list - | Pure of formula + | Pure of expr | Types of (expr * typ) list | CorePred of string * expr list * expr list | Wand of { lhs : string * expr list; rhs : string * expr list } @@ -188,10 +171,10 @@ and slcmd = and lcmd = | If of expr * lcmd list * lcmd list - | Branch of formula + | Branch of expr | Macro of string * expr list - | Assert of formula - | Assume of formula + | Assert of expr + | Assume of expr | AssumeType of expr * typ | FreshSVar of string | SL of slcmd @@ -222,7 +205,7 @@ and pred = { pred_params : (string * typ option) list; pred_ins : int list; pred_definitions : ((string * string list) option * assertion) list; - pred_facts : formula list; + pred_facts : expr list; pred_guard : assertion option; pred_pure : bool; pred_abstract : bool; diff --git a/GillianCore/GIL_Syntax/UnOp.ml b/GillianCore/GIL_Syntax/UnOp.ml index 9788bc66..bcd55827 100644 --- a/GillianCore/GIL_Syntax/UnOp.ml +++ b/GillianCore/GIL_Syntax/UnOp.ml @@ -5,7 +5,7 @@ type t = TypeDef__.unop = | IUnaryMinus (** Integer unary minus *) | FUnaryMinus (** Float unary minus *) (* Boolean *) - | UNot (** Negation *) + | Not (** Negation *) (* Bitwise *) | BitwiseNot (** Bitwise negation *) (* Mathematics *) @@ -47,13 +47,14 @@ type t = TypeDef__.unop = (* Integer vs Number *) | NumToInt (** Number to Integer - actual cast *) | IntToNum (** Integer to Number - actual cast *) + | IsInt (** IsInt e <=> (e : float) /\ (e % 1. == 0) *) [@@deriving yojson, ord, eq] let str (x : t) = match x with | IUnaryMinus -> "i-" | FUnaryMinus -> "-" - | UNot -> "not" + | Not -> "not" | BitwiseNot -> "~" | M_isNaN -> "isNaN" | M_abs -> "m_abs" @@ -83,5 +84,6 @@ let str (x : t) = | LstRev -> "l-rev" | StrLen -> "s-len" | SetToList -> "set_to_list" + | IsInt -> "is_int" | NumToInt -> "as_int" | IntToNum -> "as_num" diff --git a/GillianCore/GIL_Syntax/Visitors.ml b/GillianCore/GIL_Syntax/Visitors.ml index d2e6501b..508df7c0 100644 --- a/GillianCore/GIL_Syntax/Visitors.ml +++ b/GillianCore/GIL_Syntax/Visitors.ml @@ -75,11 +75,11 @@ module Collectors = struct inherit [_] reduce inherit Utils.ss_monoid - method! visit_ForAll exclude binders f = + method! visit_ForAll exclude binders e = (* Quantified variables need to be excluded *) let univ_quant = List.to_seq binders |> Seq.map fst in let exclude = Containers.SS.add_seq univ_quant exclude in - self#visit_formula exclude f + self#visit_expr exclude e method! visit_Exists exclude binders e = let exist_quants = List.to_seq binders |> Seq.map fst in diff --git a/GillianCore/GIL_Syntax/test/Visitors.ml b/GillianCore/GIL_Syntax/test/Visitors.ml index de72f7fa..57342647 100644 --- a/GillianCore/GIL_Syntax/test/Visitors.ml +++ b/GillianCore/GIL_Syntax/test/Visitors.ml @@ -41,7 +41,7 @@ let test_expr_base_elements () = EList [ Lit (LList [ Bool false ]); - BinOp (UnOp (UNot, Lit (Num 32.)), FPlus, PVar "b"); + BinOp (UnOp (Not, Lit (Num 32.)), FPlus, PVar "b"); ]; LVar "a"; ALoc "e"; diff --git a/GillianCore/gil_parser/GIL_Parser.mly b/GillianCore/gil_parser/GIL_Parser.mly index 1495efd8..f8c979c2 100644 --- a/GillianCore/gil_parser/GIL_Parser.mly +++ b/GillianCore/gil_parser/GIL_Parser.mly @@ -278,7 +278,7 @@ let normalised_lvar_r = Str.regexp "##NORMALISED_LVAR" %type unop_target %type binop_target %type nop_target -%type pure_assertion_target +%type pure_assertion_target %type <(Annot.t, string) Prog.t * Yojson.Safe.t> gmain_target %type top_level_expr_target @@ -436,7 +436,7 @@ expr_target: | EXISTS; vars = separated_nonempty_list(COMMA, lvar_type_target); DOT; e = expr_target { Expr.Exists (vars, e) } | LFORALL; vars = separated_nonempty_list(COMMA, lvar_type_target); DOT; e = expr_target - { Expr.EForall (vars, e) } + { Expr.ForAll (vars, e) } ; top_level_expr_target: @@ -1010,53 +1010,53 @@ existentials_target: pure_assertion_target: (* P /\ Q *) - | left_ass=pure_assertion_target; LAND; right_ass=pure_assertion_target - { Formula.And (left_ass, right_ass) } + | left_ass=expr_target; LAND; right_ass=expr_target + { Expr.BinOp (left_ass, Equal, right_ass) } (* A ==> B *) - | left_ass = pure_assertion_target; LIMPLIES; right_ass=pure_assertion_target - { Formula.Impl (left_ass, right_ass) } + | left_ass = expr_target; LIMPLIES; right_ass=expr_target + { Expr.BinOp (left_ass, Impl, right_ass) } (* P \/ Q *) - | left_ass=pure_assertion_target; LOR; right_ass=pure_assertion_target - { Formula.Or (left_ass, right_ass) } + | left_ass=expr_target; LOR; right_ass=expr_target + { Expr.BinOp (left_ass, Or, right_ass) } (* ! Q *) - | LNOT; ass=pure_assertion_target - { Formula.Not (ass) } + | LNOT; ass=expr_target + { Expr.UnOp (Not, ass) } (* true *) | LTRUE - { Formula.True } + { Expr.Lit (Bool true) } (* false *) | LFALSE - { Formula.False } + { Expr.Lit (Bool false) } (* E == E *) | left_expr=expr_target; LEQUAL; right_expr=expr_target - { Formula.Eq (left_expr, right_expr) } + { Expr.BinOp (left_expr, Equal, right_expr) } (* E i<# E *) | left_expr=expr_target; ILLESSTHAN; right_expr=expr_target - { Formula.ILess (left_expr, right_expr) } + { Expr.BinOp (left_expr, ILessThan, right_expr) } (* E <# E *) | left_expr=expr_target; FLLESSTHAN; right_expr=expr_target - { Formula.FLess (left_expr, right_expr) } + { Expr.BinOp (left_expr, FLessThan, right_expr) } (* E i<=# E *) | left_expr=expr_target; ILLESSTHANEQUAL; right_expr=expr_target - { Formula.ILessEq (left_expr, right_expr) } + { Expr.BinOp (left_expr, ILessThanEqual, right_expr) } (* E <=# E *) | left_expr=expr_target; FLLESSTHANEQUAL; right_expr=expr_target - { Formula.FLessEq (left_expr, right_expr) } + { Expr.BinOp (left_expr, FLessThanEqual, right_expr) } (* E s<# E *) | left_expr=expr_target; LSLESSTHAN; right_expr=expr_target - { Formula.StrLess (left_expr, right_expr) } + { Expr.BinOp (left_expr, StrLess, right_expr) } (* E --e-- E *) | left_expr=expr_target; LSETMEM; right_expr=expr_target - { Formula.SetMem (left_expr, right_expr) } + { Expr.BinOp (left_expr, SetMem, right_expr) } (* E --s-- E *) | left_expr=expr_target; LSETSUB; right_expr=expr_target - { Formula.SetSub (left_expr, right_expr) } + { Expr.BinOp (left_expr, SetSub, right_expr) } (* forall X, Y, Z . P *) - | LFORALL; vars = separated_nonempty_list(COMMA, lvar_type_target); DOT; ass = pure_assertion_target - { Formula.ForAll (vars, ass) } + | LFORALL; vars = separated_nonempty_list(COMMA, lvar_type_target); DOT; ass = expr_target + { Expr.ForAll (vars, ass) } (* is-int E *) | ISINT; expr=expr_target - { Formula.IsInt (expr) } + { Expr.UnOp (IsInt, expr) } (* (P) *) | LBRACE; f=pure_assertion_target; RBRACE { f } @@ -1137,10 +1137,10 @@ binop_target: | FTIMES { BinOp.FTimes } | FDIV { BinOp.FDiv } | FMOD { BinOp.FMod } - | SLT { BinOp.SLessThan } - | AND { BinOp.BAnd } - | OR { BinOp.BOr } - | LIMPLIES { BinOp.BImpl } + | SLT { BinOp.StrLess } + | AND { BinOp.And } + | OR { BinOp.Or } + | LIMPLIES { BinOp.Impl } | BITWISEAND { BinOp.BitwiseAnd } | BITWISEOR { BinOp.BitwiseOr} | BITWISEXOR { BinOp.BitwiseXor } @@ -1157,13 +1157,13 @@ binop_target: | M_POW { BinOp.M_pow } | STRCAT { BinOp.StrCat } | SETDIFF { BinOp.SetDiff } - | SETMEM { BinOp.BSetMem } - | SETSUB { BinOp.BSetSub } + | SETMEM { BinOp.SetMem } + | SETSUB { BinOp.SetSub } ; unop_target: (* Unary minus defined in (l)expr_target *) - | NOT { UnOp.UNot } + | NOT { UnOp.Not } | BITWISENOT { UnOp.BitwiseNot } | M_ISNAN { UnOp.M_isNaN } | M_ABS { UnOp.M_abs } From bafae51aec1d2f699ab68936d55628e5b3981e0e Mon Sep 17 00:00:00 2001 From: N1ark Date: Tue, 24 Dec 2024 12:40:51 +0100 Subject: [PATCH 25/54] Update FOLogic/ --- GillianCore/engine/FOLogic/FOSolver.ml | 92 +- GillianCore/engine/FOLogic/FOSolver.mli | 8 +- GillianCore/engine/FOLogic/PFS.ml | 61 +- GillianCore/engine/FOLogic/PFS.mli | 32 +- GillianCore/engine/FOLogic/Reduction.ml | 788 +++++++++--------- GillianCore/engine/FOLogic/Reduction.mli | 9 +- GillianCore/engine/FOLogic/Simplifications.ml | 197 ++--- GillianCore/engine/FOLogic/typing.ml | 112 +-- GillianCore/engine/FOLogic/typing.mli | 1 - 9 files changed, 617 insertions(+), 683 deletions(-) diff --git a/GillianCore/engine/FOLogic/FOSolver.ml b/GillianCore/engine/FOLogic/FOSolver.ml index f2bdd6ca..a6e2e16a 100644 --- a/GillianCore/engine/FOLogic/FOSolver.ml +++ b/GillianCore/engine/FOLogic/FOSolver.ml @@ -5,25 +5,26 @@ module L = Logging * SATISFIABILITY * * **************** **) -let get_axioms (fs : Formula.Set.t) (_ : Type_env.t) : Formula.Set.t = - Formula.Set.fold - (fun (pf : Formula.t) (result : Formula.Set.t) -> +let get_axioms (fs : Expr.Set.t) (_ : Type_env.t) : Expr.Set.t = + Expr.Set.fold + (fun (pf : Expr.t) (result : Expr.Set.t) -> match pf with - | Eq (NOp (LstCat, x), NOp (LstCat, y)) -> - Formula.Set.add + | BinOp (NOp (LstCat, x), Equal, NOp (LstCat, y)) -> + Expr.Set.add (Reduction.reduce_formula - (Eq + (BinOp ( UnOp (LstLen, NOp (LstCat, x)), + Equal, UnOp (LstLen, NOp (LstCat, y)) ))) result | _ -> result) - fs Formula.Set.empty + fs Expr.Set.empty let simplify_pfs_and_gamma ?(matching = false) ?relevant_info - (fs : Formula.t list) - (gamma : Type_env.t) : Formula.Set.t * Type_env.t * SESubst.t = + (fs : Expr.t list) + (gamma : Type_env.t) : Expr.Set.t * Type_env.t * SESubst.t = let pfs, gamma = match (relevant_info, !Config.under_approximation) with | Some relevant_info, false -> @@ -33,10 +34,10 @@ let simplify_pfs_and_gamma in let subst, _ = Simplifications.simplify_pfs_and_gamma ~matching pfs gamma in let fs_lst = PFS.to_list pfs in - let fs_set = Formula.Set.of_list fs_lst in + let fs_set = Expr.Set.of_list fs_lst in (fs_set, gamma, subst) -let check_satisfiability_with_model (fs : Formula.t list) (gamma : Type_env.t) : +let check_satisfiability_with_model (fs : Expr.t list) (gamma : Type_env.t) : SESubst.t option = let fs, gamma, subst = simplify_pfs_and_gamma fs gamma in let model = Smt.check_sat fs (Type_env.as_hashtbl gamma) in @@ -48,7 +49,7 @@ let check_satisfiability_with_model (fs : Formula.t list) (gamma : Type_env.t) : in Expr.Set.union ac vs) Expr.Set.empty - (List.map Formula.lvars (Formula.Set.elements fs)) + (List.map Expr.lvars (Expr.Set.elements fs)) in let smt_vars = Expr.Set.diff lvars (SESubst.domain subst None) in L.( @@ -77,15 +78,15 @@ let check_satisfiability ?(matching = false) ?time:_ ?relevant_info - (fs : Formula.t list) + (fs : Expr.t list) (gamma : Type_env.t) : bool = (* let t = if time = "" then 0. else Sys.time () in *) L.verbose (fun m -> m "Entering FOSolver.check_satisfiability"); let fs, gamma, _ = simplify_pfs_and_gamma ?relevant_info ~matching fs gamma in let axioms = get_axioms fs gamma in - let fs = Formula.Set.union fs axioms in - if Formula.Set.is_empty fs then true - else if Formula.Set.mem False fs then false + let fs = Expr.Set.union fs axioms in + if Expr.Set.is_empty fs then true + else if Expr.Set.mem Expr.false_ fs then false else let result = Smt.is_sat fs (Type_env.as_hashtbl gamma) in (* if time <> "" then @@ -96,15 +97,12 @@ let check_satisfiability let sat ~matching ~pfs ~gamma formula : bool = let formula = Reduction.reduce_formula ~matching ~pfs ~gamma formula in match formula with - | True -> + | Lit (Bool b) -> Logging.verbose (fun fmt -> fmt "Discharged sat before SMT"); - true - | False -> - Logging.verbose (fun fmt -> fmt "Discharged sat before SMT"); - false + b | _ -> let relevant_info = - (Formula.pvars formula, Formula.lvars formula, Formula.locs formula) + (Expr.pvars formula, Expr.lvars formula, Expr.locs formula) in check_satisfiability ~matching ~relevant_info (formula :: PFS.to_list pfs) @@ -118,7 +116,7 @@ let check_entailment ?(matching = false) (existentials : SS.t) (left_fs : PFS.t) - (right_fs : Formula.t list) + (right_fs : Expr.t list) (gamma : Type_env.t) : bool = L.verbose (fun m -> m @@ -157,7 +155,7 @@ let check_entailment let gamma_right = Type_env.filter gamma (fun v -> SS.mem v existentials) in (* If left side is false, return false *) - if List.mem Formula.False (left_fs @ right_fs) then false + if List.mem Expr.false_ (left_fs @ right_fs) then false else (* Check satisfiability of left side *) let left_sat = @@ -185,18 +183,18 @@ let check_entailment (* let axioms = get_axioms (left_fs @ right_fs) gamma in *) let right_fs = List.map - (fun f : Formula.t -> Formula.push_in_negations (Not f)) + (fun f : Expr.t -> Expr.push_in_negations (UnOp (Not, f))) right_fs in - let right_f : Formula.t = - if SS.is_empty existentials then Formula.disjunct right_fs + let right_f : Expr.t = + if SS.is_empty existentials then Expr.disjunct right_fs else let binders = List.map (fun x -> (x, Type_env.get gamma_right x)) (SS.elements existentials) in - ForAll (binders, Formula.disjunct right_fs) + ForAll (binders, Expr.disjunct right_fs) in let formulae = PFS.of_list (right_f :: (left_fs @ [] (* axioms *))) in @@ -204,7 +202,7 @@ let check_entailment let model = Smt.check_sat - (Formula.Set.of_list (PFS.to_list formulae)) + (Expr.Set.of_list (PFS.to_list formulae)) (Type_env.as_hashtbl gamma_left) in let ret = Option.is_none model in @@ -221,52 +219,56 @@ let check_entailment let is_equal ~pfs ~gamma e1 e2 = (* let t = Sys.time () in *) let feq = - Reduction.reduce_formula ?gamma:(Some gamma) ?pfs:(Some pfs) (Eq (e1, e2)) + Reduction.reduce_formula ?gamma:(Some gamma) ?pfs:(Some pfs) + (BinOp (e1, Equal, e2)) in let result = match feq with - | True -> true - | False -> false - | Eq _ | And _ -> check_entailment SS.empty pfs [ feq ] gamma + | Lit (Bool b) -> b + | BinOp (_, Equal, _) | BinOp (_, And, _) -> + check_entailment SS.empty pfs [ feq ] gamma | _ -> raise (Failure ("Equality reduced to something unexpected: " - ^ (Fmt.to_to_string Formula.pp) feq)) + ^ (Fmt.to_to_string Expr.pp) feq)) in (* Utils.Statistics.update_statistics "FOS: is_equal" (Sys.time () -. t); *) result let is_different ~pfs ~gamma e1 e2 = (* let t = Sys.time () in *) - let feq = Reduction.reduce_formula ~gamma ~pfs (Not (Eq (e1, e2))) in + let feq = + Reduction.reduce_formula ~gamma ~pfs (UnOp (Not, BinOp (e1, Equal, e2))) + in let result = match feq with - | True -> true - | False -> false - | Not _ -> check_entailment SS.empty pfs [ feq ] gamma + | Lit (Bool b) -> b + | Expr.UnOp (Not, _) -> check_entailment SS.empty pfs [ feq ] gamma | _ -> raise (Failure ("Inequality reduced to something unexpected: " - ^ (Fmt.to_to_string Formula.pp) feq)) + ^ (Fmt.to_to_string Expr.pp) feq)) in (* Utils.Statistics.update_statistics "FOS: is different" (Sys.time () -. t); *) result let num_is_less_or_equal ~pfs ~gamma e1 e2 = - let feq = Reduction.reduce_formula ~gamma ~pfs (FLessEq (e1, e2)) in + let feq = + Reduction.reduce_formula ~gamma ~pfs (Expr.BinOp (e1, FLessThanEqual, e2)) + in let result = match feq with - | True -> true - | False -> false - | Eq (ra, rb) -> is_equal ~pfs ~gamma ra rb - | FLessEq _ -> check_entailment SS.empty pfs [ feq ] gamma + | Lit (Bool b) -> b + | BinOp (ra, Equal, rb) -> is_equal ~pfs ~gamma ra rb + | BinOp (_, FLessThanEqual, _) -> + check_entailment SS.empty pfs [ feq ] gamma | _ -> raise (Failure ("Inequality reduced to something unexpected: " - ^ (Fmt.to_to_string Formula.pp) feq)) + ^ (Fmt.to_to_string Expr.pp) feq)) in result diff --git a/GillianCore/engine/FOLogic/FOSolver.mli b/GillianCore/engine/FOLogic/FOSolver.mli index 5dc8bcd7..7d294813 100644 --- a/GillianCore/engine/FOLogic/FOSolver.mli +++ b/GillianCore/engine/FOLogic/FOSolver.mli @@ -3,7 +3,7 @@ under the typing environment [gamma]. If this is the case, the function returns the appropriate logical environment. *) val check_satisfiability_with_model : - Gil_syntax.Formula.t list -> Type_env.t -> SVal.SESubst.t option + Gil_syntax.Expr.t list -> Type_env.t -> SVal.SESubst.t option (** [check_satisfiability ?matching pfs gamma] checks whether or not the pure formulae [pfs] are satisfiable @@ -13,13 +13,13 @@ val check_satisfiability : ?matching:bool -> ?time:string -> ?relevant_info:Containers.SS.t * Containers.SS.t * Containers.SS.t -> - Gil_syntax.Formula.t list -> + Gil_syntax.Expr.t list -> Type_env.t -> bool (** A different API for [check_satisfiability] better adapted for usage in memory models *) val sat : - matching:bool -> pfs:PFS.t -> gamma:Type_env.t -> Gil_syntax.Formula.t -> bool + matching:bool -> pfs:PFS.t -> gamma:Type_env.t -> Gil_syntax.Expr.t -> bool (** [check_entailment existentials lpfs rpfs gamma] checks whether or not the entailment << ∃ [existentials]. [lpfs] => [rpfs] >> holds @@ -28,7 +28,7 @@ val check_entailment : ?matching:bool -> Utils.Containers.SS.t -> PFS.t -> - Gil_syntax.Formula.t list -> + Gil_syntax.Expr.t list -> Type_env.t -> bool diff --git a/GillianCore/engine/FOLogic/PFS.ml b/GillianCore/engine/FOLogic/PFS.ml index 575bbe1a..f2f7dae6 100644 --- a/GillianCore/engine/FOLogic/PFS.ml +++ b/GillianCore/engine/FOLogic/PFS.ml @@ -1,24 +1,19 @@ open SVal module L = Logging -type t = Formula.t Ext_list.t [@@deriving yojson] +type t = Expr.t Ext_list.t [@@deriving yojson] let init () : t = Ext_list.make () - -let equal (pfs1 : t) (pfs2 : t) : bool = - Ext_list.for_all2 Formula.equal pfs1 pfs2 - -let to_list : t -> Formula.t list = Ext_list.to_list -let of_list : Formula.t list -> t = Ext_list.of_list +let equal (pfs1 : t) (pfs2 : t) : bool = Ext_list.for_all2 Expr.equal pfs1 pfs2 +let to_list : t -> Expr.t list = Ext_list.to_list +let of_list : Expr.t list -> t = Ext_list.of_list let to_set pfs = - Ext_list.fold_left - (fun acc el -> Formula.Set.add el acc) - Formula.Set.empty pfs + Ext_list.fold_left (fun acc el -> Expr.Set.add el acc) Expr.Set.empty pfs -let mem (pfs : t) (f : Formula.t) = Ext_list.mem ~equal:Formula.equal f pfs +let mem (pfs : t) (f : Expr.t) = Ext_list.mem ~equal:Expr.equal f pfs -let extend (pfs : t) (a : Formula.t) : unit = +let extend (pfs : t) (a : Expr.t) : unit = if not (mem pfs a) then Ext_list.add a pfs let clear (pfs : t) : unit = Ext_list.clear pfs @@ -26,37 +21,38 @@ let length (pfs : t) = Ext_list.length pfs let copy (pfs : t) : t = Ext_list.copy pfs let merge_into_left (pfs_l : t) (pfs_r : t) : unit = Ext_list.concat pfs_l pfs_r -let set (pfs : t) (reset : Formula.t list) : unit = +let set (pfs : t) (reset : Expr.t list) : unit = clear pfs; merge_into_left pfs (of_list reset) let substitution (subst : SESubst.t) (pfs : t) : unit = - Ext_list.map_inplace (SESubst.substitute_formula ~partial:true subst) pfs + Ext_list.map_inplace (SESubst.subst_in_expr ~partial:true subst) pfs let subst_expr_for_expr (to_subst : Expr.t) (subst_with : Expr.t) (pfs : t) : unit = - Ext_list.map_inplace (Formula.subst_expr_for_expr ~to_subst ~subst_with) pfs + Ext_list.map_inplace (Expr.subst_expr_for_expr ~to_subst ~subst_with) pfs let lvars (pfs : t) : SS.t = - Ext_list.fold_left (fun ac a -> SS.union ac (Formula.lvars a)) SS.empty pfs + Ext_list.fold_left (fun ac a -> SS.union ac (Expr.lvars a)) SS.empty pfs let alocs (pfs : t) : SS.t = - Ext_list.fold_left (fun ac a -> SS.union ac (Formula.alocs a)) SS.empty pfs + Ext_list.fold_left (fun ac a -> SS.union ac (Expr.alocs a)) SS.empty pfs let clocs (pfs : t) : SS.t = - Ext_list.fold_left (fun ac a -> SS.union ac (Formula.clocs a)) SS.empty pfs + Ext_list.fold_left (fun ac a -> SS.union ac (Expr.clocs a)) SS.empty pfs -let pp = Fmt.vbox (Ext_list.pp ~sep:Fmt.cut Formula.pp) +let pp = Fmt.vbox (Ext_list.pp ~sep:Fmt.cut Expr.pp) let sort (p_formulae : t) : unit = let pfl = to_list p_formulae in let var_eqs, llen_eqs, others = List.fold_left - (fun (var_eqs, llen_eqs, others) (pf : Formula.t) -> + (fun (var_eqs, llen_eqs, others) (pf : Expr.t) -> match pf with - | Eq (LVar _, _) | Eq (_, LVar _) -> (pf :: var_eqs, llen_eqs, others) - | Eq (UnOp (LstLen, _), _) | Eq (_, UnOp (LstLen, _)) -> - (var_eqs, pf :: llen_eqs, others) + | BinOp (LVar _, Equal, _) | BinOp (_, Equal, LVar _) -> + (pf :: var_eqs, llen_eqs, others) + | BinOp (UnOp (LstLen, _), Equal, _) | BinOp (_, Equal, UnOp (LstLen, _)) + -> (var_eqs, pf :: llen_eqs, others) | _ -> (var_eqs, llen_eqs, pf :: others)) ([], [], []) pfl in @@ -78,9 +74,10 @@ let get_nth = Ext_list.nth let clean_up pfs = Ext_list.filter - (fun (pf : Formula.t) -> + (fun (pf : Expr.t) -> match pf with - | Formula.ILessEq (Lit (Int x), UnOp (LstLen, _)) when x = Z.zero -> false + | Expr.BinOp (Lit (Int x), BinOp.ILessThanEqual, UnOp (LstLen, _)) + when x = Z.zero -> false | _ -> true) pfs @@ -90,10 +87,10 @@ let rec get_relevant_info (_ : SS.t) (lvars : SS.t) (locs : SS.t) (pfs : t) : let new_pvars, new_lvars, new_locs = fold_left (fun (new_pvars, new_lvars, new_locs) pf -> - let pf_pvars, pf_lvars, pf_locs = Formula.get_print_info pf in - let pf_relevant = - List.fold_left SS.union SS.empty [ pf_pvars; pf_lvars; pf_locs ] - in + let pf_pvars = Expr.pvars pf in + let pf_lvars = Expr.lvars pf in + let pf_locs = Expr.locs pf in + let pf_relevant = SS.union pf_pvars (SS.union pf_lvars pf_locs) in if SS.inter relevant pf_relevant = SS.empty then (new_pvars, new_lvars, new_locs) else @@ -116,9 +113,9 @@ let filter_with_info relevant_info (pfs : t) : t = let () = filter (fun pf -> - not - (SS.is_empty - (SS.inter relevant (SS.union (Formula.lvars pf) (Formula.locs pf))))) + let pf_info = SS.union (Expr.lvars pf) (Expr.locs pf) in + let overlap = SS.inter relevant pf_info in + not @@ SS.is_empty overlap) filtered_pfs in filtered_pfs diff --git a/GillianCore/engine/FOLogic/PFS.mli b/GillianCore/engine/FOLogic/PFS.mli index 7d08ef05..d7fd46a2 100644 --- a/GillianCore/engine/FOLogic/PFS.mli +++ b/GillianCore/engine/FOLogic/PFS.mli @@ -1,5 +1,5 @@ (** @canonical Gillian.Symbolic.Pure_context - + GIL pure formulae *) (** @canonical Gillian.Symbolic.Pure_context.t *) @@ -12,18 +12,18 @@ val init : unit -> t val equal : t -> t -> bool (** [to_list pfs] serialises the pure formulae [pfs] into a list *) -val to_list : t -> Formula.t list +val to_list : t -> Expr.t list (** [of_list fs] deserialises a list of formulae [fs] into pure formulae *) -val of_list : Formula.t list -> t +val of_list : Expr.t list -> t -val to_set : t -> Formula.Set.t +val to_set : t -> Expr.Set.t (** [mem pfs f] return true iff the formula [f] is part of the pure formulae [pfs] *) -val mem : t -> Formula.t -> bool +val mem : t -> Expr.t -> bool (** [extend pfs f] extends the pure formulae [pfs] with the formula [f] *) -val extend : t -> Formula.t -> unit +val extend : t -> Expr.t -> unit (* (** [nth_get pfs n] returns the n-th pure formula of [pfs] *) @@ -48,16 +48,16 @@ val copy : t -> t val merge_into_left : t -> t -> unit (** [set pfs fs] sets the pure formulae [pfs] to [fs] *) -val set : t -> Formula.t list -> unit +val set : t -> Expr.t list -> unit (** [iter f pfs] iterates over the pure formulae [pfs] using the function [f] *) -val iter : (Formula.t -> unit) -> t -> unit +val iter : (Expr.t -> unit) -> t -> unit (** [fold_left f ac pfs] folds over the pure formulae [pfs] using the function [f] and initial accumulator [ac] *) -val fold_left : ('a -> Formula.t -> 'a) -> 'a -> t -> 'a +val fold_left : ('a -> Expr.t -> 'a) -> 'a -> t -> 'a (** [map_inplace f pfs] is like a map operation, but performing in place *) -val map_inplace : (Formula.t -> Formula.t) -> t -> unit +val map_inplace : (Expr.t -> Expr.t) -> t -> unit (** [substitution subst pfs] substitutes the substutition subst in the pure formulae [pfs] in-place *) val substitution : SVal.SESubst.t -> t -> unit @@ -103,16 +103,16 @@ val get_relevant_info : Containers.SS.t * Containers.SS.t * Containers.SS.t val filter_map_stop : - (Formula.t -> [ `Stop | `Filter | `Replace of Formula.t ]) -> t -> bool + (Expr.t -> [ `Stop | `Filter | `Replace of Expr.t ]) -> t -> bool (** See Gillian.Utils.Ext_list.filter_stop_cond *) val filter_stop_cond : - keep:(Formula.t -> bool) -> cond:(Formula.t -> bool) -> t -> bool + keep:(Expr.t -> bool) -> cond:(Expr.t -> bool) -> t -> bool -val filter : (Formula.t -> bool) -> t -> unit -val filter_map : (Formula.t -> Formula.t option) -> t -> unit -val exists : (Formula.t -> bool) -> t -> bool +val filter : (Expr.t -> bool) -> t -> unit +val filter_map : (Expr.t -> Expr.t option) -> t -> unit +val exists : (Expr.t -> bool) -> t -> bool (** Gets the nths formula. There are very few good use cases for this function, and uses should generaly use iterators instead. O(n) *) -val get_nth : int -> t -> Formula.t option +val get_nth : int -> t -> Expr.t option diff --git a/GillianCore/engine/FOLogic/Reduction.ml b/GillianCore/engine/FOLogic/Reduction.ml index 7e0330de..bfaba885 100644 --- a/GillianCore/engine/FOLogic/Reduction.ml +++ b/GillianCore/engine/FOLogic/Reduction.ml @@ -136,7 +136,7 @@ let rec normalise_list_expressions (le : Expr.t) : Expr.t = | ESet lst -> ESet (List.map f lst) | LstSub (le1, le2, le3) -> LstSub (f le1, f le2, f le3) | Exists (bt, le) -> Exists (bt, f le) - | EForall (bt, le) -> EForall (bt, f le) + | ForAll (bt, le) -> ForAll (bt, f le) (* | LstSub(le1, le2, le3) -> (match f le1, f le2, f le3 with @@ -159,11 +159,11 @@ let rec normalise_list_expressions (le : Expr.t) : Expr.t = _____________________________________________________ *) -let resolve_list (le : Expr.t) (pfs : Formula.t list) : Expr.t = +let resolve_list (le : Expr.t) (pfs : Expr.t list) : Expr.t = let rec search x pfs = - match (pfs : Formula.t list) with + match (pfs : Expr.t list) with | [] -> None - | Eq (LVar x', le) :: rest when String.equal x' x -> ( + | BinOp (LVar x', Equal, le) :: rest when String.equal x' x -> ( let le' = normalise_list_expressions le in match le' with (* Weird things can happen where x reduces to e.g. `{{ l-nth(x, 0) }}`. @@ -173,7 +173,7 @@ let resolve_list (le : Expr.t) (pfs : Formula.t list) : Expr.t = | Expr.BinOp (_, LstRepeat, _) as ret when not (SS.mem x (Expr.lvars ret)) -> Some ret | _ -> search x rest) - | Eq (le, LVar x') :: rest when String.equal x' x -> ( + | BinOp (le, Equal, LVar x') :: rest when String.equal x' x -> ( let le' = normalise_list_expressions le in match le' with | (EList _ | NOp (LstCat, _)) when not (SS.mem x (Expr.lvars le')) -> @@ -199,7 +199,7 @@ let find_equalities (pfs : PFS.t) (le : Expr.t) : Expr.t list = List.find_all (fun x -> match x with - | Formula.Eq (x, y) -> Expr.equal x le || Expr.equal y le + | Expr.BinOp (x, Equal, y) -> Expr.equal x le || Expr.equal y le | _ -> false) lpfs in @@ -207,7 +207,7 @@ let find_equalities (pfs : PFS.t) (le : Expr.t) : Expr.t list = List.map (fun x -> match x with - | Formula.Eq (x, y) -> if Expr.equal x le then y else x + | Expr.BinOp (x, Equal, y) -> if Expr.equal x le then y else x | _ -> raise (Exceptions.Impossible @@ -259,10 +259,10 @@ let get_equal_expressions (pfs : PFS.t) nle = List.rev (PFS.fold_left (fun ac a -> - match (a : Formula.t) with - | Eq (le1, le2) when Expr.equal le1 nle -> le2 :: ac - | Eq (le2, le1) when Expr.equal le1 nle -> le2 :: ac - | Eq (e, EList el) | Eq (EList el, e) -> ( + match (a : Expr.t) with + | BinOp (le1, Equal, le2) when Expr.equal le1 nle -> le2 :: ac + | BinOp (le2, Equal, le1) when Expr.equal le1 nle -> le2 :: ac + | BinOp (e, Equal, EList el) | BinOp (EList el, Equal, e) -> ( match List_utils.index_of nle el with | None -> ac | Some index -> Expr.list_nth e index :: ac) @@ -442,8 +442,7 @@ let rec get_nth_of_string (str : Expr.t) (idx : int) : Expr.t option = (* SET REASONING HELPER FUNCTIONS *) (**********************************) -let is_different (pfs : Formula.t list) (li : Expr.t) (lj : Expr.t) : - bool option = +let is_different (pfs : Expr.t list) (li : Expr.t) (lj : Expr.t) : bool option = match li = lj with | true -> Some false | false -> ( @@ -459,20 +458,20 @@ let is_different (pfs : Formula.t list) (li : Expr.t) (lj : Expr.t) : -> Some true | _, _ -> if - List.mem (Formula.Not (Formula.Eq (li, lj))) pfs - || List.mem (Formula.Not (Formula.Eq (lj, li))) pfs + List.mem (Expr.UnOp (Not, BinOp (li, Equal, lj))) pfs + || List.mem (Expr.UnOp (Not, BinOp (lj, Equal, li))) pfs then Some true else None) (* I dont understand this! *) -let rec set_member (pfs : Formula.t list) m s = +let rec set_member (pfs : Expr.t list) m s = let f = set_member pfs m in match s with | Expr.LVar _ -> m = s | Expr.ESet s -> List.mem m s | Expr.NOp (SetUnion, les) -> List.exists (fun x -> f x) les | Expr.NOp (SetInter, les) -> List.for_all (fun x -> f x) les - | _ -> List.mem (Formula.SetMem (m, s)) pfs + | _ -> List.mem (Expr.BinOp (m, SetMem, s)) pfs let rec not_set_member pfs m s = let f = not_set_member pfs m in @@ -481,7 +480,7 @@ let rec not_set_member pfs m s = | Expr.NOp (SetInter, les) -> List.exists (fun x -> f x) les | Expr.ESet les -> List.for_all (fun le -> is_different pfs m le = Some true) les - | _ -> List.mem (Formula.Not (Formula.SetMem (m, s))) pfs + | _ -> List.mem (Expr.UnOp (Not, BinOp (m, SetMem, s))) pfs let rec set_subset pfs s s' = let f = set_subset pfs s in @@ -494,8 +493,7 @@ let rec set_subset pfs s s' = | Expr.ESet les -> List.for_all (fun x -> set_member pfs x s') les | _ -> false) -let rec contained_in_union (pfs : Formula.t list) (le1 : Expr.t) (le2 : Expr.t) - = +let rec contained_in_union (pfs : Expr.t list) (le1 : Expr.t) (le2 : Expr.t) = L.( tmi (fun m -> m "Contained in union: %s %s" @@ -505,7 +503,7 @@ let rec contained_in_union (pfs : Formula.t list) (le1 : Expr.t) (le2 : Expr.t) | LVar _ -> ( match pfs with | [] -> false - | Eq (le, NOp (SetUnion, les)) :: rest when le = le2 -> + | BinOp (le, Equal, NOp (SetUnion, les)) :: rest when le = le2 -> if List.mem le1 les then true else contained_in_union rest le1 le2 | _ :: rest -> contained_in_union rest le1 le2) | _ -> false @@ -604,7 +602,8 @@ let prefix_catch pfs (x : Expr.t) (y : string) = PFS.exists (fun pf -> match pf with - | Eq (NOp (LstCat, lx), NOp (LstCat, LVar y' :: _)) when y = y' -> ( + | BinOp (NOp (LstCat, lx), Equal, NOp (LstCat, LVar y' :: _)) + when y = y' -> ( match List_utils.list_sub lx 0 (List.length x) with | Some x' -> x' = x | _ -> false) @@ -614,8 +613,8 @@ let prefix_catch pfs (x : Expr.t) (y : string) = PFS.exists (fun pf -> match pf with - | Eq (NOp (LstCat, LVar x' :: _), NOp (LstCat, LVar y' :: _)) -> - (x' = x && y = y') || (y' = x && x' = y) + | BinOp (NOp (LstCat, LVar x' :: _), Equal, NOp (LstCat, LVar y' :: _)) + -> (x' = x && y = y') || (y' = x && x' = y) | _ -> false) pfs | _ -> false @@ -853,8 +852,8 @@ let find_list_length_eqs (pfs : PFS.t) (e : Expr.t) : Cint.t list = PFS.fold_left (fun found pf -> match pf with - | Eq (e1, e2) when e1 = llen_expr -> Cint.of_expr e2 :: found - | Eq (e1, e2) when e2 = llen_expr -> Cint.of_expr e1 :: found + | BinOp (e1, Equal, e2) when e1 = llen_expr -> Cint.of_expr e2 :: found + | BinOp (e1, Equal, e2) when e2 = llen_expr -> Cint.of_expr e1 :: found | _ -> found) [] pfs in @@ -900,6 +899,7 @@ let rec reduce_binop_inttonum_const - gamma is used for: - pfs are used for: Car, Cdr, SetDiff *) +(* TODO: can this whole mess be removed since we did sth similar with formulae? *) and reduce_lexpr_loop ?(matching = false) ?(reduce_lvars = false) @@ -923,12 +923,12 @@ and reduce_lexpr_loop | BinOp (x, FTimes, BinOp (y, FDiv, z)) when x = z -> f y | BinOp (BinOp (x, FDiv, y), FTimes, z) when y = z -> f x | BinOp (Lit (LList ll), Equal, Lit (LList lr)) -> Lit (Bool (ll = lr)) - | BinOp (left, BImpl, right) -> ( + | BinOp (left, Impl, right) -> ( let left = f left in - match Formula.lift_logic_expr left with - | None -> BinOp (left, BImpl, f right) - | Some (True, _) -> f right - | Some (False, _) -> Lit (Bool true) + match Expr.as_boolean_expr left with + | None -> BinOp (left, Impl, f right) + | Some (Lit (Bool true), _) -> f right + | Some (Lit (Bool false), _) -> Lit (Bool true) | Some (left_f, _) -> let pfs_with_left = let copy = PFS.copy pfs in @@ -939,7 +939,7 @@ and reduce_lexpr_loop reduce_lexpr_loop ~matching ~reduce_lvars pfs_with_left gamma right in - BinOp (left, BImpl, right)) + BinOp (left, Impl, right)) | BinOp (EList le, Equal, Lit (LList ll)) | BinOp (Lit (LList ll), Equal, EList le) -> if List.length ll <> List.length le then Lit (Bool false) @@ -948,7 +948,7 @@ and reduce_lexpr_loop let eqs = List.map2 (fun x y -> Expr.BinOp (x, Equal, Lit y)) le ll in let conj = List.fold_left - (fun ac x -> Expr.BinOp (ac, BAnd, x)) + (fun ac x -> Expr.BinOp (ac, And, x)) (List.hd eqs) (List.tl eqs) in f conj @@ -959,7 +959,7 @@ and reduce_lexpr_loop let eqs = List.map2 (fun x y -> Expr.BinOp (x, Equal, y)) ll lr in let conj = List.fold_left - (fun ac x -> Expr.BinOp (ac, BAnd, x)) + (fun ac x -> Expr.BinOp (ac, And, x)) (List.hd eqs) (List.tl eqs) in f conj @@ -1000,7 +1000,8 @@ and reduce_lexpr_loop (* Base sets *) | ESet les -> ESet (Expr.Set.elements (Expr.Set.of_list (List.map f les))) | UnOp (NumToInt, UnOp (IntToNum, le)) -> f le - | UnOp (IntToNum, UnOp (NumToInt, le)) when PFS.mem pfs (IsInt le) -> f le + | UnOp (IntToNum, UnOp (NumToInt, le)) when PFS.mem pfs (UnOp (IsInt, le)) + -> f le (* Number-to-string-to-number-to-string-to... *) | UnOp (ToNumberOp, UnOp (ToStringOp, le)) -> ( let fle = f le in @@ -1013,9 +1014,9 @@ and reduce_lexpr_loop | _, _ -> UnOp (ToNumberOp, UnOp (ToStringOp, fle)))) | UnOp (LstRev, UnOp (LstRev, le)) -> f le (* Less than and lessthaneq *) - | UnOp (UNot, BinOp (le1, FLessThan, le2)) -> + | UnOp (Not, BinOp (le1, FLessThan, le2)) -> f (BinOp (f le2, FLessThanEqual, f le1)) - | UnOp (UNot, BinOp (le1, FLessThanEqual, le2)) -> + | UnOp (Not, BinOp (le1, FLessThanEqual, le2)) -> f (BinOp (f le2, FLessThan, f le1)) (* Special equality *) | BinOp @@ -1145,8 +1146,8 @@ and reduce_lexpr_loop when Z.equal z Z.zero && Expr.equal x1 x2 && Expr.equal z1 y2 -> f (NOp (LstCat, LstSub (x1, Expr.zero_i, BinOp (z1, IPlus, z3)) :: rest)) - | NOp (LstCat, fst :: rest) when PFS.mem pfs (Eq (fst, EList [])) -> - f (NOp (LstCat, rest)) + | NOp (LstCat, fst :: rest) when PFS.mem pfs (BinOp (fst, Equal, EList [])) + -> f (NOp (LstCat, rest)) | NOp (LstCat, [ x; LstSub (LVar y, UnOp (LstLen, x'), len) ]) when x = x' && Cint.canonicalise len @@ -1228,13 +1229,13 @@ and reduce_lexpr_loop | e -> raise e) | _ -> ( match op with - | UNot -> ( + | Not -> ( match fle with - | UnOp (UNot, ex) -> f ex - | BinOp (ex, BAnd, ey) -> - f (BinOp (UnOp (UNot, ex), BOr, UnOp (UNot, ey))) - | BinOp (ex, BOr, ey) -> - f (BinOp (UnOp (UNot, ex), BAnd, UnOp (UNot, ey))) + | UnOp (Not, ex) -> f ex + | BinOp (ex, And, ey) -> + f (BinOp (UnOp (Not, ex), Or, UnOp (Not, ey))) + | BinOp (ex, Or, ey) -> + f (BinOp (UnOp (Not, ex), And, UnOp (Not, ey))) | _ -> def) (* The TypeOf operator *) | TypeOf -> ( @@ -1716,21 +1717,16 @@ and reduce_lexpr_loop LstSub (fle1, fle2, fle3)) (* CHECK: FTimes and Div are the same, how does the 'when' scope? *) | BinOp (lel, op, ler) -> ( - let op_is_or_and () = - match op with - | BOr | BAnd -> true - | _ -> false - in let flel, fler = (* If we're reducing A || B or A && B and either side have a reduction exception, it must be false *) let flel = try f lel with - | ReductionException _ when op_is_or_and () -> Expr.bool false + | ReductionException _ when op = Or || op = And -> Expr.bool false | exn -> raise exn in let fler = try f ler with - | ReductionException _ when op_is_or_and () -> Expr.bool false + | ReductionException _ when op = Or || op = And -> Expr.bool false | exn -> raise exn in (flel, fler) @@ -1760,13 +1756,13 @@ and reduce_lexpr_loop else if PFS.exists (fun e -> - Formula.equal e (Eq (flel, fler)) - || Formula.equal e (Eq (fler, flel))) + Expr.equal e (BinOp (flel, Equal, fler)) + || Expr.equal e (BinOp (fler, Equal, flel))) pfs then Lit (Bool true) else if - PFS.mem pfs (Not (Eq (flel, fler))) - || PFS.mem pfs (Not (Eq (fler, flel))) + PFS.mem pfs (UnOp (Not, BinOp (flel, Equal, fler))) + || PFS.mem pfs (UnOp (Not, BinOp (fler, Equal, flel))) then Lit (Bool false) else let t1, _ = Typing.type_lexpr gamma flel in @@ -1815,7 +1811,7 @@ and reduce_lexpr_loop match (flel, fler) with | x, Lit (Int o) when Z.equal o Z.one -> x | _, _ -> def) - | BAnd when lexpr_is_bool gamma def -> ( + | And when lexpr_is_bool gamma def -> ( match (flel, fler) with (* 1 is the neutral *) | Lit (Bool true), x | x, Lit (Bool true) -> x @@ -1824,17 +1820,17 @@ and reduce_lexpr_loop (* Rest *) | _, _ -> let fal, nfal = - Option.get (Formula.lift_logic_expr flel) + Option.get @@ Expr.as_boolean_expr flel in let far, nfar = - Option.get (Formula.lift_logic_expr fler) + Option.get @@ Expr.as_boolean_expr fler in if PFS.mem pfs nfal || PFS.mem pfs nfar then Lit (Bool false) else if PFS.mem pfs fal then f fler else if PFS.mem pfs far then f flel - else BinOp (flel, BAnd, fler)) - | BOr when lexpr_is_bool gamma def -> ( + else BinOp (flel, And, fler)) + | Or when lexpr_is_bool gamma def -> ( match (flel, fler) with (* 1 is the neutral *) | Lit (Bool true), _ | _, Lit (Bool true) -> Lit (Bool true) @@ -1842,16 +1838,16 @@ and reduce_lexpr_loop (* Rest *) | _, _ -> let fal, nfal = - Option.get (Formula.lift_logic_expr flel) + Option.get @@ Expr.as_boolean_expr flel in let far, nfar = - Option.get (Formula.lift_logic_expr fler) + Option.get @@ Expr.as_boolean_expr fler in if PFS.mem pfs fal || PFS.mem pfs far then Lit (Bool true) else if PFS.mem pfs nfal then f fler else if PFS.mem pfs nfar then f flel - else BinOp (flel, BOr, fler)) + else BinOp (flel, Or, fler)) | StrCat when lexpr_is_string gamma def -> ( match (flel, fler) with (* Empty list is the neutral *) @@ -1917,7 +1913,9 @@ and reduce_lexpr_loop (fun le -> Expr.BinOp (flel, SetDiff, le)) les )) | x, ESet [ el ] - when List.mem (Formula.Not (SetMem (el, x))) pfs -> x + when List.mem + (Expr.UnOp (Not, BinOp (el, SetMem, x))) + pfs -> x | LVar _, _ -> if set_subset pfs flel fler then ESet [] else def | ESet les, fler -> ( @@ -1941,7 +1939,7 @@ and reduce_lexpr_loop (match hM with | Lit (Bool true) -> ESet [] | _ -> def)) *) - | BSetMem when lexpr_is_bool gamma def -> ( + | SetMem when lexpr_is_bool gamma def -> ( match (flel, fler) with | _, ESet [] -> Lit (Bool false) | _, ESet [ x ] -> BinOp (flel, Equal, x) @@ -1955,7 +1953,7 @@ and reduce_lexpr_loop else def | _ -> def)) | _, _ -> def) - | BSetSub when lexpr_is_bool gamma def -> ( + | SetSub when lexpr_is_bool gamma def -> ( match (flel, fler) with | ESet [], _ -> Lit (Bool true) | _, ESet [] -> Lit (Bool false) @@ -2018,7 +2016,7 @@ and reduce_lexpr_loop | Some x -> Lit (Bool x) | None -> def) | _ -> def))) - | Exists (bt, e) -> ( + | ForAll (bt, e) | Exists (bt, e) -> ( (* We create a new pfs and gamma where: - All shadowed variables are substituted with a fresh variable - The gamma has been updated with the types given in the binder *) @@ -2052,48 +2050,13 @@ and reduce_lexpr_loop let vars = Expr.lvars re in let bt = List.filter (fun (b, _) -> Containers.SS.mem b vars) bt in (* We remove all quantifiers that aren't used anymore *) - match bt with - | [] -> re - | _ -> Exists (bt, re)) - | EForall (bt, e) -> ( - (* We create a new pfs and gamma where: - - All shadowed variables are substituted with a fresh variable - - The gamma has been updated with the types given in the binder *) - let new_gamma = Type_env.copy gamma in - let new_pfs = PFS.copy pfs in - let subst_bindings = List.map (fun (x, _) -> (x, LVar.alloc ())) bt in - let subst = - SVal.SESubst.init - (List.map (fun (x, y) -> (Expr.LVar x, Expr.LVar y)) subst_bindings) - in - let () = - List.iter - (fun (x, t) -> - let () = - match Type_env.get new_gamma x with - | Some t -> - let new_var = List.assoc x subst_bindings in - Type_env.update new_gamma new_var t - | None -> () - in - match t with - | Some t -> Type_env.update new_gamma x t - | None -> Type_env.remove new_gamma x) - bt - in - let () = PFS.substitution subst new_pfs in - (* We reduce using our new pfs and gamma *) - let re = - reduce_lexpr_loop ~matching ~reduce_lvars new_pfs new_gamma e - in - let vars = Expr.lvars re in - let bt = List.filter (fun (b, _) -> Containers.SS.mem b vars) bt in - (* We remove all quantifiers that aren't used anymore *) - match bt with - | [] -> re - | _ -> EForall (bt, re)) + match (le, bt) with + | _, [] -> re + | ForAll _, _ -> ForAll (bt, re) + | Exists _, _ -> Exists (bt, re) + | _, _ -> failwith "Impossible.") (* The remaining cases cannot be reduced *) - | _ -> le + | PVar _ | LVar _ | ALoc _ -> le in let result = normalise_list_expressions result in @@ -2173,9 +2136,13 @@ and check_ge_zero_int ?(top_level = false) (pfs : PFS.t) (e : Expr.t) : if List.exists (fun pf -> PFS.mem pfs pf) - [ Formula.ILessEq (Expr.zero_i, e); Formula.ILess (Expr.zero_i, e) ] + [ + Expr.BinOp (Expr.zero_i, ILessThanEqual, e); + Expr.BinOp (Expr.zero_i, ILessThan, e); + ] then Some true - else if PFS.mem pfs (Formula.ILess (e, Expr.zero_i)) then Some false + else if PFS.mem pfs (Expr.BinOp (e, ILessThan, Expr.zero_i)) then + Some false else None | LVar _ | PVar _ -> None | UnOp (IUnaryMinus, _) -> None @@ -2212,9 +2179,13 @@ and check_ge_zero_num ?(top_level = false) (pfs : PFS.t) (e : Expr.t) : if List.exists (fun pf -> PFS.mem pfs pf) - [ Formula.FLessEq (Lit (Num 0.), e); Formula.FLess (Lit (Num 0.), e) ] + [ + Expr.BinOp (Lit (Num 0.), FLessThanEqual, e); + BinOp (Lit (Num 0.), FLessThan, e); + ] then Some true - else if PFS.mem pfs (Formula.FLess (e, Lit (Num 0.))) then Some false + else if PFS.mem pfs (Expr.BinOp (e, FLessThan, Lit (Num 0.))) then + Some false else None | LVar _ | PVar _ -> None | UnOp (FUnaryMinus, _) -> None @@ -2395,11 +2366,11 @@ and substitute_for_list_length (pfs : PFS.t) (le : Expr.t) : Expr.t = List.filter_map (fun pf -> match pf with - | Formula.Eq (UnOp (LstLen, LVar x), lex) + | Expr.BinOp (UnOp (LstLen, LVar x), Equal, lex) when match lex with | UnOp (LstLen, LVar _) | Lit _ -> false | _ -> true -> Some (Expr.LVar x, lex) - | Eq (lex, UnOp (LstLen, LVar x)) + | BinOp (lex, Equal, UnOp (LstLen, LVar x)) when match lex with | UnOp (LstLen, LVar _) | Lit _ -> false | _ -> true -> Some (Expr.LVar x, lex) @@ -2490,103 +2461,110 @@ let rec reduce_formula_loop (matching : bool) (pfs : PFS.t) (gamma : Type_env.t) - ?(previous = Formula.True) - (a : Formula.t) : Formula.t = + ?(previous = Expr.Lit (Bool true)) + (a : Expr.t) : Expr.t = Logging.tmi (fun m -> m "Reduce formula: %a -> %a" (fun ft f -> match f with - | Formula.True -> + | Expr.Lit (Bool true) -> Fmt.pf ft "STARTING TO REDUCE: matching %b, rpfs %b" matching rpfs - | _ -> Formula.pp ft f) - previous Formula.pp a); - if Formula.equal a previous then + | _ -> Expr.pp ft f) + previous Expr.pp a); + if Expr.equal a previous then let () = - Logging.tmi (fun m -> m "Finished reducing, obtained: %a" Formula.pp a) + Logging.tmi (fun m -> m "Finished reducing, obtained: %a" Expr.pp a) in a else let f = reduce_formula_loop ~rpfs matching pfs gamma in let fe = reduce_lexpr_loop ~matching pfs gamma in - let result : Formula.t = + let result : Expr.t = match a with - | Eq (e1, e2) when Expr.equal e1 e2 -> True + | BinOp (e1, Equal, e2) when Expr.equal e1 e2 -> Expr.true_ (* DEDICATED SIMPLIFICATIONS - this should probably be handled properly by SMT... *) - | Eq (BinOp (Lit (Num x), FPlus, LVar y), LVar z) - when x <> 0. && String.equal y z -> False - | Eq (BinOp (Lit (Int x), IPlus, LVar y), LVar z) - when (not (Z.equal x Z.zero)) && String.equal y z -> False + | BinOp (BinOp (Lit (Num x), FPlus, LVar y), Equal, LVar z) + when x <> 0. && String.equal y z -> Expr.false_ + | BinOp (BinOp (Lit (Int x), IPlus, LVar y), Equal, LVar z) + when (not (Z.equal x Z.zero)) && String.equal y z -> Expr.false_ | ForAll ( [ (x, Some IntType) ], - Or - ( Or (ILess (LVar a, Lit (Int z)), ILessEq (Lit (Int len), LVar b)), - Eq (BinOp (EList c, LstNth, LVar d), e) ) ) + BinOp + ( BinOp + ( BinOp (LVar a, ILessThan, Lit (Int z)), + Or, + BinOp (Lit (Int len), ILessThanEqual, LVar b) ), + Or, + BinOp (BinOp (EList c, LstNth, LVar d), Equal, e) ) ) when Z.equal z Z.zero && String.equal x a && String.equal a b && String.equal b d && Int.equal (List.compare_length_with c (Z.to_int len)) 0 -> let rhs = Expr.EList (List_utils.make (Z.to_int len) e) in - Eq (EList c, rhs) + BinOp (EList c, Equal, rhs) (* FIXME: INTEGER BYTE-BY-BYTE BREAKDOWN *) - | Eq + | BinOp ( Lit (Int n), + Equal, BinOp (BinOp (Lit (Int tfs), ITimes, LVar b1), IPlus, LVar b0) ) when top_level && Z.equal tfs _256 - && PFS.mem pfs (ILessEq (Expr.zero_i, LVar b0)) - && PFS.mem pfs (ILessEq (Expr.zero_i, LVar b1)) - && PFS.mem pfs (ILess (LVar b0, Lit (Int _256))) - && PFS.mem pfs (ILess (LVar b1, Lit (Int _256))) -> - if Z.gt n _65535 then False + && PFS.mem pfs (BinOp (Expr.zero_i, ILessThanEqual, LVar b0)) + && PFS.mem pfs (BinOp (Expr.zero_i, ILessThanEqual, LVar b1)) + && PFS.mem pfs (BinOp (LVar b0, ILessThan, Lit (Int _256))) + && PFS.mem pfs (BinOp (LVar b1, ILessThan, Lit (Int _256))) -> + if Z.gt n _65535 then Expr.false_ else let vb1 = Z.div n _256 in let vb0 = Z.sub n vb1 in - Formula.And - (Eq (LVar b1, Lit (Int vb1)), Eq (LVar b0, Lit (Int vb0))) - | Eq + Expr.BinOp + ( BinOp (LVar b1, Equal, Lit (Int vb1)), + And, + BinOp (LVar b0, Equal, Lit (Int vb0)) ) + | BinOp ( BinOp (BinOp (Lit (Int tfs), ITimes, LVar b1), IPlus, LVar b0), + Equal, Lit (Int n) ) when top_level && Z.equal tfs _256 - && PFS.mem pfs (ILessEq (Expr.zero_i, LVar b0)) - && PFS.mem pfs (ILessEq (Expr.zero_i, LVar b1)) - && PFS.mem pfs (ILess (LVar b0, Lit (Int _256))) - && PFS.mem pfs (ILess (LVar b1, Lit (Int _256))) -> - if Z.gt n _65535 then False + && PFS.mem pfs (BinOp (Expr.zero_i, ILessThanEqual, LVar b0)) + && PFS.mem pfs (BinOp (Expr.zero_i, ILessThanEqual, LVar b1)) + && PFS.mem pfs (BinOp (LVar b0, ILessThan, Lit (Int _256))) + && PFS.mem pfs (BinOp (LVar b1, ILessThan, Lit (Int _256))) -> + if Z.gt n _65535 then Expr.false_ else let vb1 = Z.div n _256 in let vb0 = Z.sub n vb1 in - Formula.And - (Eq (LVar b1, Lit (Int vb1)), Eq (LVar b0, Lit (Int vb0))) - | Eq (BinOp (e, FTimes, Lit (Num x)), Lit (Num 0.)) when x <> 0. -> - Eq (e, Lit (Num 0.)) - | Eq (BinOp (e, ITimes, Lit (Int x)), Lit (Int n)) - when Z.equal n Z.zero && not (Z.equal x Z.zero) -> Eq (e, Expr.zero_i) - | Eq (BinOp (Lit (Num x), FTimes, e), Lit (Num 0.)) when x <> 0. -> - Eq (e, Lit (Num 0.)) - | Eq (BinOp (Lit (Int x), ITimes, e), Lit (Int z)) - when Z.equal z Z.zero && not (Z.equal x Z.zero) -> Eq (e, Expr.zero_i) - | Eq (Lit (LList ll), Lit (LList lr)) -> if ll = lr then True else False - | Eq (EList le, Lit (LList ll)) | Eq (Lit (LList ll), EList le) -> - if List.length ll <> List.length le then False - else if ll = [] then True + BinOp + ( BinOp (LVar b1, Equal, Lit (Int vb1)), + And, + BinOp (LVar b0, Equal, Lit (Int vb0)) ) + | BinOp (BinOp (e, FTimes, Lit (Num x)), Equal, Lit (Num 0.)) when x <> 0. + -> BinOp (e, Equal, Lit (Num 0.)) + | BinOp (BinOp (Lit (Num x), FTimes, e), Equal, Lit (Num 0.)) when x <> 0. + -> BinOp (e, Equal, Lit (Num 0.)) + | BinOp (BinOp (e, ITimes, Lit (Int x)), Equal, Lit (Int n)) + when Z.equal n Z.zero && not (Z.equal x Z.zero) -> + BinOp (e, Equal, Expr.zero_i) + | BinOp (BinOp (Lit (Int x), ITimes, e), Equal, Lit (Int n)) + when Z.equal n Z.zero && not (Z.equal x Z.zero) -> + BinOp (e, Equal, Expr.zero_i) + | BinOp (Lit (LList ll), Equal, Lit (LList lr)) -> Expr.bool (ll = lr) + | BinOp (EList le, Equal, Lit (LList ll)) + | BinOp (Lit (LList ll), Equal, EList le) -> + if List.length ll <> List.length le then Expr.false_ + else if ll = [] then Expr.true_ else - let eqs = List.map2 (fun x y -> Formula.Eq (x, Lit y)) le ll in - let conj = - List.fold_left - (fun ac x -> Formula.And (ac, x)) - (List.hd eqs) (List.tl eqs) + let eqs = + List.map2 (fun x y -> Expr.BinOp (x, Equal, Lit y)) le ll in + let conj = Expr.conjunct eqs in conj - | Eq (EList ll, EList lr) -> - if List.length ll <> List.length lr then False - else if ll = [] then True + | BinOp (EList ll, Equal, EList lr) -> + if List.length ll <> List.length lr then Expr.false_ + else if ll = [] then Expr.true_ else - let eqs = List.map2 (fun x y -> Formula.Eq (x, y)) ll lr in - let conj = - List.fold_left - (fun ac x -> Formula.And (ac, x)) - (List.hd eqs) (List.tl eqs) - in + let eqs = List.map2 (fun x y -> Expr.BinOp (x, Equal, y)) ll lr in + let conj = Expr.conjunct eqs in conj - | Eq (left_list, right_list) + | BinOp (left_list, Equal, right_list) when (match ( Typing.type_lexpr gamma left_list, Typing.type_lexpr gamma right_list ) @@ -2604,55 +2582,54 @@ let rec reduce_formula_loop | _ -> false -> (* If we have two lists but can reduce the equality of their lengths to false, then we know the lists cannot be equal*) - False - | Eq (NOp (LstCat, les), LVar x) + Expr.false_ + | BinOp (NOp (LstCat, les), Equal, LVar x) when List.mem (Expr.LVar x) les && List.exists (fun e -> match e with | Expr.EList (_ :: _) | Lit (LList (_ :: _)) -> true | _ -> false) - les -> False - | Eq (UnOp (NumToInt, le), re) -> Eq (le, UnOp (IntToNum, re)) - | Eq (le, UnOp (NumToInt, re)) -> Eq (UnOp (IntToNum, le), re) - | And (a1, a2) -> ( + les -> Expr.false_ + | BinOp (UnOp (NumToInt, le), Equal, re) -> + BinOp (le, Equal, UnOp (IntToNum, re)) + | BinOp (le, Equal, UnOp (NumToInt, re)) -> + BinOp (UnOp (IntToNum, le), Equal, re) + | BinOp (a1, And, a2) -> let fa1 = f a1 in let fa2 = f a2 in - match (fa1, fa2) with - | False, _ | _, False -> False - | True, a | a, True -> a - | _, _ -> And (fa1, fa2)) - | Or (a1, a2) -> ( + Expr.Infix.( && ) fa1 fa2 + | BinOp (a1, Or, a2) -> ( let fa1 = f a1 in let fa2 = f a2 in match (fa1, fa2) with - | False, a | a, False -> a - | True, _ | _, True -> True + | Expr.Lit (Bool false), a | a, Expr.Lit (Bool false) -> a + | Expr.Lit (Bool true), _ | _, Expr.Lit (Bool true) -> + Expr.Lit (Bool true) | _, _ -> - if PFS.mem pfs fa1 || PFS.mem pfs fa2 then True - else if PFS.mem pfs (Not fa1) then fa2 - else if PFS.mem pfs (Not fa2) then fa1 - else Or (fa1, fa2)) + if PFS.mem pfs fa1 || PFS.mem pfs fa2 then Expr.Lit (Bool true) + else if PFS.mem pfs (UnOp (Not, fa1)) then fa2 + else if PFS.mem pfs (UnOp (Not, fa2)) then fa1 + else BinOp (fa1, Or, fa2)) (* JOSE: why the recursive call? *) - | Not a -> ( + | UnOp (Not, a) -> ( let fa = f a in match a with - | True -> False - | False -> True - | Not a -> a - | Or (a1, a2) -> And (Not a1, Not a2) - | And (a1, a2) -> Or (Not a1, Not a2) - | FLess (e1, e2) -> FLessEq (e2, e1) - | FLessEq (e1, e2) -> FLess (e2, e1) - | ILess (e1, e2) -> ILessEq (e2, e1) - | ILessEq (e1, e2) -> ILess (e2, e1) - | _ -> Not fa) - | Eq (e1, e2) -> ( + | Lit (Bool b) -> Lit (Bool (not b)) + | UnOp (Not, a) -> a + | BinOp (a1, Or, a2) -> BinOp (UnOp (Not, a1), And, UnOp (Not, a2)) + | BinOp (a1, And, a2) -> BinOp (UnOp (Not, a1), Or, UnOp (Not, a2)) + | BinOp (e1, FLessThan, e2) -> BinOp (e2, FLessThanEqual, e1) + | BinOp (e1, FLessThanEqual, e2) -> BinOp (e2, FLessThan, e1) + | BinOp (e1, ILessThan, e2) -> BinOp (e2, ILessThanEqual, e1) + | BinOp (e1, ILessThanEqual, e2) -> BinOp (e2, ILessThan, e1) + | _ -> UnOp (Not, fa)) + | BinOp (e1, Equal, e2) -> ( let re1 = fe e1 in let re2 = fe e2 in (* Warning - NaNs, infinities, this and that, this is not good enough *) let eq = re1 = re2 in - if eq then True + if eq then Expr.true_ else let t1, s1 = Typing.type_lexpr gamma re1 in let t2, s2 = Typing.type_lexpr gamma re2 in @@ -2662,58 +2639,57 @@ let rec reduce_formula_loop match (t1, t2) with | Some t1, Some t2 -> t1 <> t2 | _, _ -> false - then False + then Expr.false_ else - let ite a b : Formula.t = if a = b then True else False in - let default re1 re2 : Formula.t = Eq (re1, re2) in + let ite a b = Expr.bool (a = b) in + let default re1 re2 = Expr.BinOp (re1, Equal, re2) in match (re1, re2) with (* DEDICATED RPFS REDUCTIONS *) | NOp (LstCat, _), LVar y when rpfs && prefix_catch pfs re1 y -> - Eq (UnOp (LstLen, re1), UnOp (LstLen, re2)) + BinOp (UnOp (LstLen, re1), Equal, UnOp (LstLen, re2)) | LVar x, NOp (LstCat, LstSub (y, UnOp (LstLen, z), len) :: t) when rpfs && PFS.mem pfs - (Eq (NOp (LstCat, y :: t), NOp (LstCat, [ z; LVar x ]))) + (BinOp + ( NOp (LstCat, y :: t), + Equal, + NOp (LstCat, [ z; LVar x ]) )) && Cint.canonicalise len = Cint.canonicalise (BinOp (UnOp (LstLen, y), IMinus, UnOp (LstLen, z))) - -> True + -> Expr.true_ (* USUAL REDUCTIONS *) - | ALoc _, Lit (Loc _) | Lit (Loc _), ALoc _ -> False - | ALoc x, ALoc y when (not matching) && x <> y -> False + | ALoc _, Lit (Loc _) | Lit (Loc _), ALoc _ -> Expr.false_ + | ALoc x, ALoc y when (not matching) && x <> y -> Expr.false_ | EList [], x | x, EList [] | Lit (LList []), x | x, Lit (LList []) -> ( match x with - | Lit (LList lst) when List.length lst > 0 -> False - | EList lst when List.length lst > 0 -> False - | NOp (LstCat, les) -> - if - List.exists - (fun (x : Expr.t) -> - match x with - | EList le when List.length le > 0 -> true - | Lit (LList le) when List.length le > 0 -> true - | _ -> false) - les - then False - else Eq (re1, re2) - | _ -> Eq (re1, re2)) + | Lit (LList lst) when List.length lst > 0 -> Expr.false_ + | EList lst when List.length lst > 0 -> Expr.false_ + | NOp (LstCat, les) + when List.exists + (function + | Expr.EList (_ :: _) | Lit (LList (_ :: _)) -> + true + | _ -> false) + les -> Expr.false_ + | _ -> BinOp (re1, Equal, re2)) (* Lifting *) + | Lit (Bool true), _ when t2 = Some Type.BooleanType -> re2 + | _, Lit (Bool true) when t1 = Some Type.BooleanType -> re1 | Lit (Bool true), BinOp (x, Equal, y) - | BinOp (x, Equal, y), Lit (Bool true) -> Eq (x, y) - | Lit (Bool true), UnOp (UNot, BinOp (x, Equal, y)) -> - Not (Eq (x, y)) - | UnOp (UNot, BinOp (x, Equal, y)), Lit (Bool true) -> - Not (Eq (x, y)) - | Lit (Bool false), BinOp (x, Equal, y) -> Not (Eq (x, y)) - | BinOp (x, Equal, y), Lit (Bool false) -> Not (Eq (x, y)) - | Lit (Bool false), UnOp (UNot, BinOp (x, Equal, y)) -> - Not (Eq (x, y)) - | UnOp (UNot, BinOp (x, Equal, y)), Lit (Bool false) -> - Not (Eq (x, y)) - | UnOp (LstRev, ll), UnOp (LstRev, rl) -> Eq (ll, rl) + | BinOp (x, Equal, y), Lit (Bool true) + | Lit (Bool false), UnOp (Not, BinOp (x, Equal, y)) + | UnOp (Not, BinOp (x, Equal, y)), Lit (Bool false) -> + BinOp (x, Equal, y) + | Lit (Bool true), UnOp (Not, BinOp (x, Equal, y)) + | UnOp (Not, BinOp (x, Equal, y)), Lit (Bool true) + | Lit (Bool false), BinOp (x, Equal, y) + | BinOp (x, Equal, y), Lit (Bool false) -> + UnOp (Not, BinOp (x, Equal, y)) + | UnOp (LstRev, ll), UnOp (LstRev, rl) -> BinOp (ll, Equal, rl) (* TODO: This is a specialised simplification, not sure for what, disabled for now | UnOp (LstRev, full_list), BinOp (UnOp (LstRev, plist_left), LstCat, plist_right) | BinOp (UnOp (LstRev, plist_left), LstCat, plist_right), UnOp (LstRev, full_list) @@ -2721,46 +2697,52 @@ let rec reduce_formula_loop f (Eq (full_list, BinOp (UnOp (LstRev, plist_right), LstCat, plist_left))) *) | LstSub (e1, Lit (Int z), el), e2 when Z.equal z Z.zero && Expr.equal e1 e2 -> - Eq (UnOp (LstLen, e1), el) + BinOp (UnOp (LstLen, e1), Equal, el) | e2, LstSub (e1, Lit (Int z), el) when Z.equal z Z.zero && Expr.equal e1 e2 -> - Eq (UnOp (LstLen, e1), el) + BinOp (UnOp (LstLen, e1), Equal, el) | e2, LstSub (NOp (LstCat, e1 :: _), Lit (Int z), el) when Z.equal z Z.zero && Expr.equal e1 e2 -> - Eq (UnOp (LstLen, e1), el) + BinOp (UnOp (LstLen, e1), Equal, el) | LstSub (NOp (LstCat, e1 :: _), Lit (Int z), el), e2 when Z.equal z Z.zero && Expr.equal e1 e2 -> - Eq (UnOp (LstLen, e1), el) + BinOp (UnOp (LstLen, e1), Equal, el) | e2, LstSub (NOp (LstCat, e3 :: e1 :: _), ex, ey) when Expr.equal e1 e2 -> - And (Eq (UnOp (LstLen, e3), ex), Eq (UnOp (LstLen, e1), ey)) + BinOp + ( BinOp (UnOp (LstLen, e3), Equal, ex), + And, + BinOp (UnOp (LstLen, e1), Equal, ey) ) | LstSub (NOp (LstCat, e3 :: e1 :: _), ex, ey), e2 when Expr.equal e1 e2 -> - And (Eq (UnOp (LstLen, e3), ex), Eq (UnOp (LstLen, e1), ey)) + BinOp + ( BinOp (UnOp (LstLen, e3), Equal, ex), + And, + BinOp (UnOp (LstLen, e1), Equal, ey) ) | NOp (LstCat, fl :: rl), NOp (LstCat, fr :: rr) - when Expr.equal fl fr -> Eq (NOp (LstCat, rl), NOp (LstCat, rr)) + when Expr.equal fl fr -> + BinOp (NOp (LstCat, rl), Equal, NOp (LstCat, rr)) | NOp (LstCat, fl :: rl), NOp (LstCat, fr :: rr) when Expr.equal (List.hd (List.rev (fl :: rl))) (List.hd (List.rev (fr :: rr))) -> f - (Eq + (BinOp ( NOp (LstCat, List.rev (List.tl (List.rev (fl :: rl)))), + Equal, NOp (LstCat, List.rev (List.tl (List.rev (fr :: rr)))) )) | ( LVar lst, NOp (LstCat, LstSub (LVar lst', Lit (Int z), split) :: _rest) ) when Z.equal z Z.zero && String.equal lst lst' - && PFS.mem pfs (ILess (UnOp (LstLen, LVar lst), split)) -> - False + && PFS.mem pfs + (BinOp (UnOp (LstLen, LVar lst), ILessThan, split)) -> + Expr.false_ | le1, le2 - when (match le1 with - | LVar _ -> false + when (match (le1, le2) with + | LVar _, _ | _, LVar _ -> false | _ -> true) - && (match le2 with - | LVar _ -> false - | _ -> true) && lexpr_is_list gamma le1 && lexpr_is_list gamma le2 -> ( let htl1, htl2 = ( get_head_and_tail_of_list ~pfs le1, @@ -2768,28 +2750,35 @@ let rec reduce_formula_loop in match (htl1, htl2) with | Some (hl1, tl1), Some (hl2, tl2) -> - And (Eq (hl1, hl2), Eq (tl1, tl2)) + BinOp + (BinOp (hl1, Equal, hl2), And, BinOp (tl1, Equal, tl2)) | None, Some _ -> ( match le1 with - | Lit (LList _) | EList _ -> False - | _ -> Eq (re1, re2)) + | Lit (LList _) | EList _ -> Expr.false_ + | _ -> BinOp (re1, Equal, re2)) | Some _, None -> ( match le2 with - | Lit (LList _) | EList _ -> False - | _ -> Eq (re1, re2)) - | None, None -> Eq (re1, re2)) + | Lit (LList _) | EList _ -> Expr.false_ + | _ -> BinOp (re1, Equal, re2)) + | None, None -> BinOp (re1, Equal, re2)) (* Strings #1 *) | Lit (String ls), BinOp (Lit (String rs), StrCat, s) | BinOp (Lit (String rs), StrCat, s), Lit (String ls) -> ( let lls = String.length ls in let lrs = String.length rs in match Stdlib.compare lls lrs with - | -1 -> False - | 0 -> if ls <> rs then False else Eq (s, Lit (String "")) + | -1 -> Expr.false_ + | 0 -> + if ls <> rs then Expr.false_ + else BinOp (s, Equal, Lit (String "")) | 1 -> let sub = String.sub ls 0 lrs in - if sub <> rs then False - else Eq (s, Lit (String (String.sub ls lrs (lls - lrs)))) + if sub <> rs then Expr.false_ + else + BinOp + ( s, + Equal, + Lit (String (String.sub ls lrs (lls - lrs))) ) | _ -> raise (Exceptions.Impossible @@ -2797,34 +2786,42 @@ let rec reduce_formula_loop match/filter")) (* String #2 *) | BinOp (sl1, StrCat, sr1), BinOp (sl2, StrCat, sr2) - when sl1 = sl2 -> Eq (sr1, sr2) + when sl1 = sl2 -> BinOp (sr1, Equal, sr2) | BinOp (sl1, StrCat, sr1), BinOp (sl2, StrCat, sr2) - when sr1 = sr2 -> Eq (sl1, sl2) + when sr1 = sr2 -> BinOp (sl1, Equal, sl2) (* String #3 *) - | BinOp (sl, StrCat, sr), s when sl = s -> Eq (sr, Lit (String "")) - | BinOp (sl, StrCat, sr), s when sr = s -> Eq (sl, Lit (String "")) - | s, BinOp (sl, StrCat, sr) when sl = s -> Eq (sr, Lit (String "")) - | s, BinOp (sl, StrCat, sr) when sr = s -> Eq (sl, Lit (String "")) + | BinOp (sl, StrCat, sr), s when sl = s -> + BinOp (sr, Equal, Lit (String "")) + | BinOp (sl, StrCat, sr), s when sr = s -> + BinOp (sl, Equal, Lit (String "")) + | s, BinOp (sl, StrCat, sr) when sl = s -> + BinOp (sr, Equal, Lit (String "")) + | s, BinOp (sl, StrCat, sr) when sr = s -> + BinOp (sl, Equal, Lit (String "")) | BinOp (sl, StrCat, sr), Lit (String "") -> - And (Eq (sl, Lit (String "")), Eq (sr, Lit (String ""))) + BinOp + ( BinOp (sl, Equal, Lit (String "")), + And, + BinOp (sr, Equal, Lit (String "")) ) (* Num-to-String injectivity *) - | UnOp (ToStringOp, le1), UnOp (ToStringOp, le2) -> Eq (le1, le2) + | UnOp (ToStringOp, le1), UnOp (ToStringOp, le2) -> + BinOp (le1, Equal, le2) (* Num-to-String understanding *) | UnOp (ToStringOp, le1), Lit (String s) | Lit (String s), UnOp (ToStringOp, le1) -> ( match s with - | "" -> False + | "" -> Expr.false_ | "Infinity" | "-Infinity" | "NaN" -> default re1 re2 | _ -> ( let num = try Some (Float.of_string s) with _ -> None in match num with - | Some num -> Eq (le1, Lit (Num num)) - | None -> False)) + | Some num -> BinOp (le1, Equal, Lit (Num num)) + | None -> Expr.false_)) (* The empty business *) | _, Lit Empty -> ( match re1 with - | Lit l when l <> Empty -> False - | EList _ | ESet _ -> False + | Lit l when l <> Empty -> Expr.false_ + | EList _ | ESet _ -> Expr.false_ | _ -> default re1 re2) | Lit l1, Lit l2 -> ite l1 l2 | Lit Nono, PVar _ | PVar _, Lit Nono -> default re1 re2 @@ -2833,128 +2830,96 @@ let rec reduce_formula_loop let tx = Type_env.get gamma x in match tx with | None | Some NoneType -> default re1 re2 - | _ -> False) - | Lit Nono, _ | _, Lit Nono -> False - | Lit (Bool true), BinOp (e1, FLessThan, e2) -> FLess (e1, e2) + | _ -> Expr.false_) + | Lit Nono, _ | _, Lit Nono -> Expr.false_ + | Lit (Bool true), BinOp (e1, FLessThan, e2) -> + BinOp (e1, FLessThan, e2) | Lit (Bool false), BinOp (e1, FLessThan, e2) -> - Not (FLess (e1, e2)) - | Lit (Bool true), BinOp (e1, ILessThan, e2) -> ILess (e1, e2) + BinOp (e2, FLessThanEqual, e1) + | Lit (Bool true), BinOp (e1, ILessThan, e2) -> + BinOp (e1, ILessThan, e2) | Lit (Bool false), BinOp (e1, ILessThan, e2) -> - Not (ILess (e1, e2)) + BinOp (e2, ILessThanEqual, e1) (* FPlus theory -> theory? I would not go that far *) | le1, le2 when lexpr_is_number le1 && lexpr_is_number le2 -> let success, le1', le2' = Cnum.cut le1 le2 in - if success then Eq (le1', le2') else Eq (le1, le2) + if success then BinOp (le1', Equal, le2') + else BinOp (le1, Equal, le2) | le1, le2 when lexpr_is_int le1 && lexpr_is_int le2 -> let success, le1', le2' = Cint.cut le1 le2 in - if success then Eq (le1', le2') else Eq (le1, le2) + if success then BinOp (le1', Equal, le2') + else BinOp (le1, Equal, le2) (* Very special cases *) | UnOp (TypeOf, BinOp (_, StrCat, _)), Lit (Type t) - when t <> StringType -> False - | UnOp (TypeOf, BinOp (_, BSetMem, _)), Lit (Type t) - when t <> BooleanType -> False + when t <> StringType -> Expr.false_ + | UnOp (TypeOf, BinOp (_, SetMem, _)), Lit (Type t) + when t <> BooleanType -> Expr.false_ (* Set unions *) | ( NOp (SetUnion, [ ls; ESet [ lx ] ]), NOp (SetUnion, [ rs; ESet [ rx ] ]) ) when lx = rx -> if - PFS.mem pfs (Not (SetMem (lx, ls))) - && PFS.mem pfs (Not (SetMem (lx, rs))) - then Eq (ls, rs) + PFS.mem pfs (UnOp (Not, BinOp (lx, SetMem, ls))) + && PFS.mem pfs (UnOp (Not, BinOp (lx, SetMem, rs))) + then BinOp (ls, Equal, rs) else default re1 re2 | _, _ -> default re1 re2) - | FLess (e1, e2) -> - if PFS.mem pfs (FLessEq (e2, e1)) then False - else if PFS.mem pfs (FLess (e2, e1)) then False - else - let le = Option.get (Formula.to_expr (FLess (e1, e2))) in - let re = fe le in - let result, _ = Option.get (Formula.lift_logic_expr re) in - result - | ILess (e1, e2) -> - if PFS.mem pfs (ILessEq (e2, e1)) then False - else if PFS.mem pfs (ILess (e2, e1)) then False - else - let le = Option.get (Formula.to_expr (ILess (e1, e2))) in - let re = fe le in - let result, _ = Option.get (Formula.lift_logic_expr re) in - result - | ILessEq (Lit (Int z), UnOp (LstLen, _)) when Z.equal z Z.zero -> True - | FLessEq (e1, e2) -> - if PFS.mem pfs (FLessEq (e2, e1)) then Eq (e1, e2) - else if PFS.mem pfs (FLess (e1, e2)) then True - else if PFS.mem pfs (FLess (e2, e1)) then False - else - let le = Option.get (Formula.to_expr (FLessEq (e1, e2))) in - let re = fe le in - let result, _ = Option.get (Formula.lift_logic_expr re) in - result - | ILessEq (e1, e2) -> - if PFS.mem pfs (ILessEq (e2, e1)) then Eq (e1, e2) - else if PFS.mem pfs (ILess (e1, e2)) then True - else if PFS.mem pfs (ILess (e2, e1)) then False - else - let le = Option.get (Formula.to_expr (ILessEq (e1, e2))) in - let re = fe le in - let result, _ = Option.get (Formula.lift_logic_expr re) in - result - | SetMem (leb, NOp (SetUnion, lle)) -> - let rleb = fe leb in - let formula : Formula.t = - match lle with - | [] -> False - | le :: lle -> - let rle = fe le in - List.fold_left - (fun ac le : Formula.t -> - let rle = fe le in - Or (ac, SetMem (rleb, rle))) - (SetMem (rleb, rle)) - lle + | BinOp (Lit (Int z), ILessThanEqual, UnOp (LstLen, _)) + when Z.equal z Z.zero -> Expr.true_ + | BinOp (e1, (FLessThan as op), e2) | BinOp (e1, (ILessThan as op), e2) -> + let rev : BinOp.t = + if op = FLessThan then FLessThanEqual else ILessThanEqual in - formula - | SetMem (leb, NOp (SetInter, lle)) -> - let rleb = fe leb in - let formula : Formula.t = - match lle with - | [] -> False - | le :: lle -> - let rle = fe le in - List.fold_left - (fun ac le : Formula.t -> - let rle = fe le in - And (ac, SetMem (rleb, rle))) - (SetMem (rleb, rle)) - lle + if PFS.mem pfs (BinOp (e2, rev, e1)) then Expr.false_ + else if PFS.mem pfs (BinOp (e2, op, e1)) then Expr.false_ + else fe (Expr.BinOp (e1, op, e2)) + | BinOp (e1, (FLessThanEqual as op), e2) + | BinOp (e1, (ILessThanEqual as op), e2) -> + let rev : BinOp.t = + if op = FLessThanEqual then FLessThan else ILessThan in - formula - | SetMem (leb, BinOp (lel, SetDiff, ler)) -> + if PFS.mem pfs (BinOp (e2, rev, e1)) then BinOp (e1, Equal, e2) + else if PFS.mem pfs (BinOp (e1, op, e2)) then Expr.true_ + else if PFS.mem pfs (BinOp (e2, op, e1)) then Expr.false_ + else fe (Expr.BinOp (e1, op, e2)) + | BinOp (leb, SetMem, NOp ((SetUnion as op), lle)) + | BinOp (leb, SetMem, NOp ((SetInter as op), lle)) -> ( + let rleb = fe leb in + match lle with + | [] -> Expr.false_ + | le :: lle -> + let bop : BinOp.t = if op = SetUnion then Or else And in + let rle = fe le in + List.fold_left + (fun ac le -> + let rle = fe le in + Expr.BinOp (ac, bop, BinOp (rleb, SetMem, rle))) + (Expr.BinOp (rleb, SetMem, rle)) + lle) + | BinOp (leb, SetMem, BinOp (lel, SetDiff, ler)) -> let rleb = fe leb in let rlel = fe lel in let rler = fe ler in - And (SetMem (rleb, rlel), Not (SetMem (rleb, rler))) - | SetMem (leb, ESet les) -> + BinOp + ( BinOp (rleb, SetMem, rlel), + And, + UnOp (Not, BinOp (rleb, SetMem, rler)) ) + | BinOp (leb, SetMem, ESet les) -> let rleb = fe leb in let rles = List.map (fun le -> fe le) les in - let result : Formula.t list = - List.map (fun le : Formula.t -> Eq (rleb, le)) rles - in - List.fold_left - (fun ac eq : Formula.t -> - match (ac : Formula.t) with - | False -> eq - | _ -> Or (ac, eq)) - False result - | IsInt e -> ( + let result = List.map (fun le -> Expr.BinOp (rleb, Equal, le)) rles in + Expr.disjunct result + | UnOp (IsInt, e) -> ( match fe e with | UnOp (UnOp.IntToNum, e) -> ( let t, _ = Typing.type_lexpr gamma e in match t with - | Some IntType -> True - | Some _ -> False - | None -> f @@ Eq (UnOp (TypeOf, e), Lit (Type IntType))) - | _ -> a) - | Impl (left, right) -> ( + | Some IntType -> Expr.true_ + | Some _ -> Expr.false_ + | None -> f @@ BinOp (UnOp (TypeOf, e), Equal, Lit (Type IntType)) + ) + | e' -> UnOp (IsInt, e')) + | BinOp (left, Impl, right) -> ( let pfs_with_left = let copy = PFS.copy pfs in let () = PFS.extend copy left in @@ -2964,30 +2929,23 @@ let rec reduce_formula_loop reduce_formula_loop ~rpfs:true matching pfs_with_left gamma left in match (reduced_left, f right) with - | True, _ -> right - | False, _ | _, True -> True - | _, False -> f (Not left) - | _ -> Impl (left, right)) + | Lit (Bool true), _ -> right + | Lit (Bool false), _ | _, Lit (Bool true) -> Expr.true_ + | _, Lit (Bool false) -> f (UnOp (Not, left)) + | _ -> BinOp (left, Impl, right)) | ForAll ( [ (i, Some IntType) ], - Impl - ( And - ( ILessEq (Lit (Int z), LVar i'), - ILess (LVar i'', UnOp (LstLen, l)) ), - Eq (BinOp (l', LstNth, LVar i'''), k) ) ) + BinOp + ( BinOp + ( BinOp (Lit (Int z), ILessThanEqual, LVar i'), + And, + BinOp (LVar i'', ILessThan, UnOp (LstLen, (EList ll as l))) + ), + Impl, + BinOp (BinOp (l', LstNth, LVar i'''), Equal, k) ) ) when Z.(equal z zero) - && i = i' && i' = i'' && i'' = i''' && Expr.equal l l' - && - match l with - | EList _ -> true - | _ -> false -> - let l = - match l with - | EList l -> l - | _ -> failwith "unreachable" - in - List.map (fun x -> Formula.Infix.(x #== k)) l - |> List.fold_left Formula.Infix.( #&& ) Formula.True + && i = i' && i' = i'' && i'' = i''' && Expr.equal l l' -> + List.map (fun x -> Expr.Infix.(x == k)) ll |> Expr.conjunct | ForAll (bt, a) -> ( (* We create a new pfs and gamma where: - All shadowed variables are substituted with a fresh variable @@ -3019,7 +2977,7 @@ let rec reduce_formula_loop let () = PFS.substitution subst new_pfs in (* We reduce using our new pfs and gamma *) let ra = reduce_formula_loop ~rpfs matching new_pfs new_gamma a in - let vars = Formula.lvars ra in + let vars = Expr.lvars ra in let bt = List.filter (fun (b, _) -> Containers.SS.mem b vars) bt in (* We remove all quantifiers that aren't used anymore *) match bt with @@ -3036,14 +2994,14 @@ let reduce_formula ?time:_ ?(pfs : PFS.t = PFS.init ()) ?(gamma = Type_env.init ()) - (a : Formula.t) : Formula.t = + (a : Expr.t) : Expr.t = reduce_formula_loop ~top_level:true ~rpfs matching pfs gamma a let relate_llen (pfs : PFS.t) (gamma : Type_env.t) (e : Expr.t) - (lcat : Expr.t list) : (Formula.t * Containers.SS.t) option = + (lcat : Expr.t list) : (Expr.t * Containers.SS.t) option = (* Loop *) let rec relate_llen_loop (llen : Cint.t) @@ -3114,15 +3072,15 @@ let relate_llen | [] -> [] | _ -> [ Expr.EList new_lvars ] in - let pf = Formula.Eq (e, NOp (LstCat, les @ new_lvars)) in - L.verbose (fun fmt -> fmt "Constructed equality: %a" Formula.pp pf); + let pf = Expr.BinOp (e, Equal, NOp (LstCat, les @ new_lvars)) in + L.verbose (fun fmt -> fmt "Constructed equality: %a" Expr.pp pf); (pf, Containers.SS.of_list new_vars) | false, exp -> let rest_var = LVar.alloc () in let rest = Expr.LVar rest_var in - let pfeq = Formula.Eq (e, NOp (LstCat, les @ [ rest ])) in - let pflen = Formula.Eq (UnOp (LstLen, rest), exp) in - (Formula.And (pfeq, pflen), Containers.SS.singleton rest_var) + let pfeq = Expr.BinOp (e, Equal, NOp (LstCat, les @ [ rest ])) in + let pflen = Expr.BinOp (UnOp (LstLen, rest), Equal, exp) in + (Expr.BinOp (pfeq, And, pflen), Containers.SS.singleton rest_var) | _ -> failwith "Impossible by construction") (relate_llen_loop llen [] lcat) in @@ -3142,7 +3100,7 @@ let understand_lstcat (pfs : PFS.t) (gamma : Type_env.t) (lcat : Expr.t list) - (rcat : Expr.t list) : (Formula.t * Containers.SS.t) option = + (rcat : Expr.t list) : (Expr.t * Containers.SS.t) option = L.tmi (fun fmt -> fmt "Understanding LstCat: %a, %a" Fmt.(brackets (list ~sep:semi Expr.pp)) @@ -3176,10 +3134,10 @@ let reduce_types (a : Asrt.t) : Asrt.t = let others, ets = List.fold_left (fun (others, ets) -> function - | Asrt.Pure True -> (others, ets) - | Asrt.Pure False -> raise PFSFalse - | Asrt.Pure (Eq (UnOp (TypeOf, e), Lit (Type t))) - | Asrt.Pure (Eq (Lit (Type t), UnOp (TypeOf, e))) -> + | Asrt.Pure (Lit (Bool true)) -> (others, ets) + | Asrt.Pure (Lit (Bool false)) -> raise PFSFalse + | Asrt.Pure (BinOp (UnOp (TypeOf, e), Equal, Lit (Type t))) + | Asrt.Pure (BinOp (Lit (Type t), Equal, UnOp (TypeOf, e))) -> (others, (e, t) :: ets) | Asrt.Types ets' -> (others, ets' @ ets) | a -> (a :: others, ets)) @@ -3188,11 +3146,11 @@ let reduce_types (a : Asrt.t) : Asrt.t = let ets = ETSet.elements (ETSet.of_list ets) in match (others, ets) with - | [], [] -> [ Asrt.Pure True ] (* Could this be []? *) + | [], [] -> [ Asrt.Pure (Lit (Bool true)) ] (* Could this be []? *) | [], ets -> [ Asrt.Types ets ] | others, [] -> others | others, ets -> Asrt.Types ets :: others - with PFSFalse -> [ Asrt.Pure False ] + with PFSFalse -> [ Asrt.Pure (Lit (Bool false)) ] (* Reduction of assertions *) let reduce_assertion_loop @@ -3216,7 +3174,7 @@ let reduce_assertion_loop (* Predicates *) | Pred (name, les) -> [ Pred (name, List.map fe les) ] (* Pure assertions *) - | Pure True -> [] + | Pure (Lit (Bool true)) -> [] | Pure f -> [ Pure (reduce_formula_loop ~top_level:true matching pfs gamma f) ] (* Types *) @@ -3232,14 +3190,16 @@ let reduce_assertion_loop lvt [] in if lvt = [] then [] else [ Types lvt ] - with WrongType -> [ Pure False ]) + with WrongType -> [ Pure (Lit (Bool false)) ]) (* General action *) | CorePred (act, l_ins, l_outs) -> [ CorePred (act, List.map fe l_ins, List.map fe l_outs) ] in let result = List.concat_map f a in let result = - if List.mem (Asrt.Pure False) result then [ Asrt.Pure False ] else result + if List.mem (Asrt.Pure (Lit (Bool false))) result then + [ Asrt.Pure (Lit (Bool false)) ] + else result in (if a <> result && not (a == result) then @@ -3248,7 +3208,7 @@ let reduce_assertion_loop let extract_lvar_equalities : Asrt.t -> (string * Expr.t) list = List.filter_map @@ function - | Asrt.Pure (Eq (LVar x, v) | Eq (v, LVar x)) -> + | Asrt.Pure (BinOp (LVar x, Equal, v) | BinOp (v, Equal, LVar x)) -> if Names.is_lvar_name x && not (Names.is_spec_var_name x) then Some (x, v) else None | _ -> None @@ -3283,6 +3243,4 @@ let reduce_assertion loop a let is_tautology ?pfs ?gamma formula = - match reduce_formula ?pfs ?gamma formula with - | True -> true - | _ -> false + reduce_formula ?pfs ?gamma formula = Lit (Bool true) diff --git a/GillianCore/engine/FOLogic/Reduction.mli b/GillianCore/engine/FOLogic/Reduction.mli index bad6f5c5..135d8352 100644 --- a/GillianCore/engine/FOLogic/Reduction.mli +++ b/GillianCore/engine/FOLogic/Reduction.mli @@ -18,7 +18,7 @@ val understand_lstcat : Type_env.t -> Expr.t list -> Expr.t list -> - (Formula.t * Containers.SS.t) option + (Expr.t * Containers.SS.t) option (** [reduce_lexpr ?matching ?reduce_lvars ?pfs ?gamma e] reduces the expression [e] given (optional) pure formulae [pfs] and typing environment [gamma]. @@ -40,8 +40,8 @@ val reduce_formula : ?time:string -> ?pfs:PFS.t -> ?gamma:Type_env.t -> - Gil_syntax.Formula.t -> - Gil_syntax.Formula.t + Gil_syntax.Expr.t -> + Gil_syntax.Expr.t (** [reduce_assertion ?matching ?pfs ?gamma a] reduces the assertion [a] given (optional) pure formulae [pfs] and typing environment [gamma]. @@ -53,5 +53,4 @@ val reduce_assertion : Gil_syntax.Asrt.t -> Gil_syntax.Asrt.t -val is_tautology : - ?pfs:PFS.t -> ?gamma:Type_env.t -> Gil_syntax.Formula.t -> bool +val is_tautology : ?pfs:PFS.t -> ?gamma:Type_env.t -> Gil_syntax.Expr.t -> bool diff --git a/GillianCore/engine/FOLogic/Simplifications.ml b/GillianCore/engine/FOLogic/Simplifications.ml index e2f6f462..733c3c2c 100644 --- a/GillianCore/engine/FOLogic/Simplifications.ml +++ b/GillianCore/engine/FOLogic/Simplifications.ml @@ -5,7 +5,7 @@ module SB = Containers.SB type simpl_key_type = { kill_new_lvars : bool option; gamma_list : (Var.t * Type.t) list; - pfs_list : Formula.t list; + pfs_list : Expr.t list; existentials : SS.t; matching : bool; save_spec_vars : (SS.t * bool) option; (* rpfs_lvars : CCommon.SS.t *) @@ -13,7 +13,7 @@ type simpl_key_type = { type simpl_val_type = { simpl_gamma : (Var.t * Type.t) list; - simpl_pfs : Formula.t list; + simpl_pfs : Expr.t list; simpl_existentials : SS.t; subst : SVal.SESubst.t; } @@ -50,24 +50,25 @@ let sanitise_pfs_no_store ?(matching = false) = let clean_up_stuff (left : PFS.t) (right : PFS.t) = let sleft = PFS.to_set left in let pf_sym pfa pfb = - match ((pfa, pfb) : Formula.t * Formula.t) with - | Eq (a, b), Eq (c, d) when a = d && b = c -> true - | Not (Eq (a, b)), Not (Eq (c, d)) when a = d && b = c -> true + match ((pfa, pfb) : Expr.t * Expr.t) with + | BinOp (a, Equal, b), BinOp (c, Equal, d) when a = d && b = c -> true + | UnOp (Not, BinOp (a, Equal, b)), UnOp (Not, BinOp (c, Equal, d)) + when a = d && b = c -> true | _ -> false in let eq_or_sym pfa pfb = pfa = pfb || pf_sym pfa pfb in - let keep pf = not (Formula.Set.exists (eq_or_sym pf) sleft) in + let keep pf = not (Expr.Set.exists (eq_or_sym pf) sleft) in let cond pf = let npf = match pf with - | Formula.Not pf -> pf - | _ -> Not pf + | Expr.UnOp (Not, pf) -> pf + | _ -> UnOp (Not, pf) in - Formula.Set.exists (eq_or_sym npf) sleft + Expr.Set.exists (eq_or_sym npf) sleft in if PFS.filter_stop_cond ~keep ~cond right then let () = PFS.clear right in - PFS.set left [ False ] + PFS.set left [ Expr.false_ ] (* Set intersections *) let get_num_set_intersections pfs = @@ -76,16 +77,22 @@ let get_num_set_intersections pfs = List.iter (fun pf -> - match (pf : Formula.t) with + match (pf : Expr.t) with | ForAll ( [ (x, Some NumberType) ], - Or (Not (SetMem (LVar y, LVar set)), FLess (LVar elem, LVar z)) ) + BinOp + ( UnOp (Not, BinOp (LVar y, SetMem, LVar set)), + Or, + BinOp (LVar elem, FLessThan, LVar z) ) ) when x = y && x = z -> L.(verbose (fun m -> m "Got left: %s, %s" elem set)); Hashtbl.add lvars elem set | ForAll ( [ (x, Some NumberType) ], - Or (Not (SetMem (LVar y, LVar set)), FLess (LVar z, LVar elem)) ) + BinOp + ( UnOp (Not, BinOp (LVar y, SetMem, LVar set)), + Or, + BinOp (LVar z, FLessThan, LVar elem) ) ) when x = y && x = z -> L.(verbose (fun m -> m "Got right: %s, %s" elem set)); Hashtbl.add rvars elem set @@ -133,8 +140,8 @@ let get_num_set_intersections pfs = (* 4. *) List.iter (fun a -> - match (a : Formula.t) with - | FLess (LVar v1, LVar v2) -> ( + match (a : Expr.t) with + | BinOp (LVar v1, FLessThan, LVar v2) -> ( match (Hashtbl.mem lvars v1, Hashtbl.mem lvars v2) with | true, true -> intersections := @@ -181,35 +188,25 @@ let _resolve_set_existentials (List.map (fun e -> (Fmt.to_to_string Expr.pp) e) s)) intersections)))); - let filter_map_fun (formula_to_filter : Formula.t) = + let filter_map_fun (formula_to_filter : Expr.t) = match formula_to_filter with - | Eq (NOp (SetUnion, ul), NOp (SetUnion, ur)) -> + | BinOp (NOp (SetUnion, ul), Equal, NOp (SetUnion, ur)) -> (* Expand ESets *) - let ul = - List.flatten - (List.map - (fun (u : Expr.t) : Expr.t list -> - match (u : Expr.t) with - | ESet x -> - List.map (fun (x : Expr.t) : Expr.t -> ESet [ x ]) x - | _ -> [ u ]) - ul) - in - let ur = - List.flatten - (List.map - (fun (u : Expr.t) : Expr.t list -> - match u with - | ESet x -> List.map (fun x : Expr.t -> ESet [ x ]) x - | _ -> [ u ]) - ur) + let aux e = + List.concat_map + (function + | Expr.ESet x -> List.map (fun x : Expr.t -> ESet [ x ]) x + | u -> [ u ]) + e in + let ul = aux ul in + let ur = aux ur in let sul = Expr.Set.of_list ul in let sur = Expr.Set.of_list ur in L.verbose (fun m -> m "Resolve set existentials: I have found a union equality."); - L.verbose (fun m -> m "%a" Formula.pp formula_to_filter); + L.verbose (fun m -> m "%a" Expr.pp formula_to_filter); (* Trying to cut the union *) let same_parts = Expr.Set.inter sul sur in @@ -291,7 +288,7 @@ let _resolve_set_existentials Type_env.remove gamma v done; None - | _ -> Some (Formula.Eq (lhs, rhs)) + | _ -> Some (Expr.BinOp (lhs, Equal, rhs)) else Some formula_to_filter) else Some formula_to_filter | _ -> Some formula_to_filter @@ -342,9 +339,9 @@ let simplify_pfs_and_gamma PFS.set lpfs simpl_pfs; (* Deal with rpfs *) - if PFS.length lpfs > 0 && PFS.get_nth 0 lpfs == Some False then ( + if PFS.length lpfs > 0 && PFS.get_nth 0 lpfs == Some Expr.false_ then ( PFS.clear rpfs; - PFS.extend rpfs True); + PFS.extend rpfs Expr.true_); (SESubst.copy subst, simpl_existentials) | false -> @@ -378,9 +375,9 @@ let simplify_pfs_and_gamma (* Pure formulae false *) let pfs_false lpfs rpfs : unit = PFS.clear lpfs; - PFS.extend lpfs False; + PFS.extend lpfs Expr.false_; PFS.clear rpfs; - PFS.extend rpfs True + PFS.extend rpfs Expr.true_ in let stop_explain (msg : string) : [> `Stop ] = @@ -388,8 +385,8 @@ let simplify_pfs_and_gamma `Stop in (* PF simplification *) - let rec filter_mapper_formula (pfs : PFS.t) (pf : Formula.t) : - [ `Stop | `Replace of Formula.t | `Filter ] = + let rec filter_mapper_formula (pfs : PFS.t) (pf : Expr.t) : + [ `Stop | `Replace of Expr.t | `Filter ] = (* Reduce current assertion *) let rec_call = filter_mapper_formula pfs in let extend_with = PFS.extend pfs in @@ -401,15 +398,15 @@ let simplify_pfs_and_gamma List.iter (fun x -> Type_env.remove gamma x) lx; `Replace whole (* And is expanded *) - | And (a1, a2) -> + | BinOp (a1, And, a2) -> extend_with a2; rec_call a1 (* If we find true, we can delete it *) - | True -> `Filter + | Lit (Bool true) -> `Filter (* If we find false, the entire pfs are false *) - | False -> stop_explain "False in pure formulae" + | Lit (Bool false) -> stop_explain "False in pure formulae" (* Inequality of things with different types *) - | Not (Eq (le1, le2)) -> ( + | UnOp (Not, BinOp (le1, Equal, le2)) -> ( let te1, _ = Typing.type_lexpr gamma le1 in let te2, _ = Typing.type_lexpr gamma le2 in match (te1, te2) with @@ -420,8 +417,8 @@ let simplify_pfs_and_gamma || te1 = NoneType) -> stop_explain "Inequality of two undefined/null/empty/none" | _ -> `Replace whole) - | Eq (BinOp (lst, LstNth, idx), elem) - | Eq (elem, BinOp (lst, LstNth, idx)) -> ( + | BinOp (BinOp (lst, LstNth, idx), Equal, elem) + | BinOp (elem, Equal, BinOp (lst, LstNth, idx)) -> ( match idx with | Lit (Int nx) -> let prepend_lvars = @@ -435,36 +432,39 @@ let simplify_pfs_and_gamma let prepend = List.map (fun x -> Expr.LVar x) prepend_lvars in let append = Expr.LVar append_lvar in rec_call - (Eq + (BinOp ( lst, + Equal, NOp ( LstCat, [ EList (List.append prepend [ elem ]); append ] ) )) | Lit (Num _) -> failwith "l-nth(l, f) where f is Num and not Int!" | _ -> `Replace whole) - | Eq (UnOp (LstLen, le), Lit (Int z)) when Z.equal z Z.zero -> - rec_call (Eq (le, EList [])) - | Eq (Lit (Int z), UnOp (LstLen, le)) when Z.equal z Z.zero -> - rec_call (Eq (le, EList [])) - | Eq (UnOp (LstLen, le), Lit (Int len)) - | Eq (Lit (Int len), UnOp (LstLen, le)) + | BinOp (UnOp (LstLen, le), Equal, Lit (Int z)) when Z.equal z Z.zero -> + rec_call (BinOp (le, Equal, EList [])) + | BinOp (Lit (Int z), Equal, UnOp (LstLen, le)) when Z.equal z Z.zero -> + rec_call (BinOp (le, Equal, EList [])) + | BinOp (UnOp (LstLen, le), Equal, Lit (Int len)) + | BinOp (Lit (Int len), Equal, UnOp (LstLen, le)) when (not matching) && Z.leq len (Z.of_int 100) -> let len = Z.to_int len in if len >= 0 then ( let le_vars = List.init len (fun _ -> LVar.alloc ()) in vars_to_kill := SS.union !vars_to_kill (SS.of_list le_vars); let le' = List.map (fun x -> Expr.LVar x) le_vars in - rec_call (Eq (le, EList le'))) + rec_call (BinOp (le, Equal, EList le'))) else stop_explain "List length an unexpected integer." - | Eq (NOp (LstCat, les), EList []) - | Eq (NOp (LstCat, les), Lit (LList [])) - | Eq (EList [], NOp (LstCat, les)) - | Eq (Lit (LList []), NOp (LstCat, les)) -> - let eqs = List.map (fun le -> Formula.Eq (le, EList [])) les in + | BinOp (NOp (LstCat, les), Equal, EList []) + | BinOp (NOp (LstCat, les), Equal, Lit (LList [])) + | BinOp (EList [], Equal, NOp (LstCat, les)) + | BinOp (Lit (LList []), Equal, NOp (LstCat, les)) -> + let eqs = + List.map (fun le -> Expr.BinOp (le, Equal, EList [])) les + in List.iter (fun eq -> extend_with eq) eqs; `Filter (* Two list concats, Satan save us *) - | Eq (NOp (LstCat, lcat), NOp (LstCat, rcat)) -> ( + | BinOp (NOp (LstCat, lcat), Equal, NOp (LstCat, rcat)) -> ( match Reduction.understand_lstcat lpfs gamma lcat rcat with | None -> `Replace whole | Some (pf, new_vars) -> @@ -472,21 +472,23 @@ let simplify_pfs_and_gamma vars_to_kill := SS.union !vars_to_kill new_vars; `Replace whole) (* *) - | Eq (UnOp (LstLen, x), BinOp (Lit (Int n), IPlus, LVar z)) + | BinOp (UnOp (LstLen, x), Equal, BinOp (Lit (Int n), IPlus, LVar z)) when Z.geq n Z.zero -> let new_lvars = List.init (Z.to_int n) (fun _ -> Expr.LVar (LVar.alloc ())) in let rest = LVar.alloc () in let lst_eq = - Formula.Eq (x, NOp (LstCat, [ EList new_lvars; LVar rest ])) + Expr.BinOp (x, Equal, NOp (LstCat, [ EList new_lvars; LVar rest ])) + in + let len_rest = + Expr.BinOp (UnOp (LstLen, LVar rest), Equal, LVar z) in - let len_rest = Formula.Eq (UnOp (LstLen, LVar rest), LVar z) in extend_with len_rest; `Replace lst_eq (* Sublist *) - | Eq (LstSub (lst, start, num), sl) | Eq (sl, LstSub (lst, start, num)) - -> + | BinOp (LstSub (lst, start, num), Equal, sl) + | BinOp (sl, Equal, LstSub (lst, start, num)) -> let prefix_lvar = LVar.alloc () in let suffix_lvar = LVar.alloc () in vars_to_kill := @@ -502,17 +504,21 @@ let simplify_pfs_and_gamma fmt "Reduced suffix length: %a" Expr.pp suffix_len); let lst_eq = if suffix_len = Expr.zero_i then - Formula.Eq (lst, NOp (LstCat, [ LVar prefix_lvar; sl ])) + Expr.BinOp (lst, Equal, NOp (LstCat, [ LVar prefix_lvar; sl ])) else - Formula.Eq - (lst, NOp (LstCat, [ LVar prefix_lvar; sl; LVar suffix_lvar ])) + Expr.BinOp + ( lst, + Equal, + NOp (LstCat, [ LVar prefix_lvar; sl; LVar suffix_lvar ]) ) + in + let len_pr = + Expr.BinOp (UnOp (LstLen, LVar prefix_lvar), Equal, start) in - let len_pr = Formula.Eq (UnOp (LstLen, LVar prefix_lvar), start) in - let len_sl = Formula.Eq (UnOp (LstLen, sl), num) in + let len_sl = Expr.BinOp (UnOp (LstLen, sl), Equal, num) in extend_with len_pr; extend_with len_sl; `Replace lst_eq - | Eq (le1, le2) -> ( + | BinOp (le1, Equal, le2) -> ( let te1, _ = Typing.type_lexpr gamma le1 in let te2, _ = Typing.type_lexpr gamma le2 in match (te1, te2) with @@ -555,7 +561,7 @@ let simplify_pfs_and_gamma in PFS.substitution temp_subst lpfs; let substituted = - SESubst.substitute_formula ~partial:true temp_subst whole + SESubst.subst_in_expr ~partial:true temp_subst whole in rec_call substituted | ALoc alocl, ALoc alocr when not matching -> @@ -612,7 +618,7 @@ let simplify_pfs_and_gamma ((Fmt.to_to_string Expr.pp) le) ((Fmt.to_to_string Expr.pp) le'))); *) if le <> le' then - PFS.extend lpfs (Eq (le, le'))); + PFS.extend lpfs (BinOp (le, Equal, le'))); SESubst.iter result (fun x le -> let sle = SESubst.subst_in_expr temp_subst @@ -704,21 +710,22 @@ let simplify_pfs_and_gamma (fun (lens, cats, xcats) pf -> match pf with (* List length direct equality *) - | Eq (UnOp (LstLen, LVar x), UnOp (LstLen, LVar y)) + | BinOp (UnOp (LstLen, LVar x), Equal, UnOp (LstLen, LVar y)) when not (String.equal x y) -> let lens = map_add (UnOp (LstLen, LVar y)) (LVar x) lens in (map_add (UnOp (LstLen, LVar x)) (LVar y) lens, cats, xcats) (* List length equals some other expression on the right *) - | Eq (UnOp (LstLen, LVar x), rhs) + | BinOp (UnOp (LstLen, LVar x), Equal, rhs) when not (List.mem (Expr.LVar x) (Expr.base_elements rhs)) -> (map_add rhs (LVar x) lens, cats, xcats) (* List length equals some other expression on the left *) - | Eq (lhs, UnOp (LstLen, LVar x)) + | BinOp (lhs, Equal, UnOp (LstLen, LVar x)) when not (List.mem (Expr.LVar x) (Expr.base_elements lhs)) -> (map_add lhs (LVar x) lens, cats, xcats) (*************** CATS **************) (* Two cats *) - | Eq (NOp (LstCat, LVar a :: b), NOp (LstCat, LVar c :: d)) + | BinOp + (NOp (LstCat, LVar a :: b), Equal, NOp (LstCat, LVar c :: d)) when a <> c -> let cats = map_map_add @@ -744,12 +751,12 @@ let simplify_pfs_and_gamma (NOp (LstCat, LVar a :: b)) xcats ) (* One cat on the left *) - | Eq (NOp (LstCat, LVar a :: b), rhs) -> + | BinOp (NOp (LstCat, LVar a :: b), Equal, rhs) -> ( lens, map_map_add rhs (Expr.LVar a) (NOp (LstCat, b)) cats, map_add (NOp (LstCat, LVar a :: b)) rhs xcats ) (* One cat on the right *) - | Eq (lhs, NOp (LstCat, LVar a :: b)) -> + | BinOp (lhs, Equal, NOp (LstCat, LVar a :: b)) -> ( lens, map_map_add lhs (Expr.LVar a) (NOp (LstCat, b)) cats, map_add (NOp (LstCat, LVar a :: b)) lhs xcats ) @@ -772,7 +779,7 @@ let simplify_pfs_and_gamma L.verbose (fun fmt -> fmt "ULTRA LSTCAT: cat equality: %a and %a" Expr.pp x Expr.pp y); - PFS.extend pfs (Eq (x, y)) + PFS.extend pfs (BinOp (x, Equal, y)) done done) eqs) @@ -787,7 +794,7 @@ let simplify_pfs_and_gamma L.verbose (fun fmt -> fmt "ULTRA LSTCAT: xcat equality: %a and %a" Expr.pp x Expr.pp y); - PFS.extend pfs (Eq (x, y)) + PFS.extend pfs (BinOp (x, Equal, y)) done done) xcats; @@ -820,13 +827,13 @@ let simplify_pfs_and_gamma L.verbose (fun fmt -> fmt "ULTRA LSTCAT: head equality: %a and %a" Expr.pp x Expr.pp y); - PFS.extend pfs (Eq (x, y)); + PFS.extend pfs (Expr.BinOp (x, Equal, y)); let x = Expr.Map.find x eqcats in let y = Expr.Map.find y eqcats in L.verbose (fun fmt -> fmt "ULTRA LSTCAT: tail equality: %a and %a" Expr.pp x Expr.pp y); - PFS.extend pfs (Eq (x, y)) + PFS.extend pfs (Expr.BinOp (x, Equal, y)) done done) cats) @@ -859,7 +866,7 @@ let simplify_pfs_and_gamma if PFS.length lpfs = 0 - || (PFS.length lpfs > 0 && not (PFS.get_nth 0 lpfs = Some False)) + || (PFS.length lpfs > 0 && not (PFS.get_nth 0 lpfs = Some Expr.false_)) then ( (* Step 3 - Bring back my variables *) SESubst.iter result (fun v le -> @@ -871,7 +878,7 @@ let simplify_pfs_and_gamma || (kill_new_lvars && SS.mem v vars_to_save) || ((not kill_new_lvars) && vars_to_save <> SS.empty)) && not (Names.is_aloc_name v) - then PFS.extend lpfs (Eq (LVar v, le)) + then PFS.extend lpfs (BinOp (LVar v, Equal, le)) | _ -> ()); sanitise_pfs_no_store ~matching gamma lpfs; @@ -885,7 +892,10 @@ let simplify_pfs_and_gamma match t with | Type.ListType -> PFS.extend lpfs - (ILessEq (Expr.zero_i, UnOp (LstLen, Expr.from_var_name v))) + (BinOp + ( Expr.zero_i, + ILessThanEqual, + UnOp (LstLen, Expr.from_var_name v) )) | _ -> ()); analyse_list_structure lpfs; @@ -946,13 +956,14 @@ let simplify_implication (gamma : Type_env.t) = (* let t = Sys.time () in *) List.iter - (fun (pf : Formula.t) -> + (fun (pf : Expr.t) -> match pf with - | Eq (NOp (LstCat, lex), NOp (LstCat, ley)) -> + | BinOp (NOp (LstCat, lex), Equal, NOp (LstCat, ley)) -> let flen_eq = Reduction.reduce_formula ~gamma ~pfs:lpfs - (Eq + (BinOp ( UnOp (LstLen, NOp (LstCat, lex)), + Equal, UnOp (LstLen, NOp (LstCat, ley)) )) in PFS.extend lpfs flen_eq @@ -1011,7 +1022,7 @@ let admissible_assertion (a : Asrt.t) : bool = try List.iter separate a; let _ = simplify_pfs_and_gamma ~kill_new_lvars:true pfs gamma in - let res = not (PFS.mem pfs Formula.False) in + let res = not (PFS.mem pfs Expr.false_) in L.tmi (fun m -> m "Admissible? %b" res); res with e -> diff --git a/GillianCore/engine/FOLogic/typing.ml b/GillianCore/engine/FOLogic/typing.ml index 9548b955..62152568 100644 --- a/GillianCore/engine/FOLogic/typing.ml +++ b/GillianCore/engine/FOLogic/typing.ml @@ -19,8 +19,8 @@ module Infer_types_to_gamma = struct (tt : Type.t) = let f = f flag gamma new_gamma in match op with - | UNot -> tt = BooleanType && f le BooleanType - | M_isNaN -> tt = BooleanType && f le NumberType + | Not -> tt = BooleanType && f le BooleanType + | IsInt | M_isNaN -> tt = BooleanType && f le NumberType | IUnaryMinus -> tt = IntType && f le IntType | FUnaryMinus | BitwiseNot @@ -70,13 +70,12 @@ module Infer_types_to_gamma = struct (Some IntType, Some IntType, Some BooleanType) | FLessThan | FLessThanEqual -> (Some NumberType, Some NumberType, Some BooleanType) - | SLessThan -> (Some StringType, Some StringType, Some BooleanType) - | BAnd | BOr | BImpl -> - (Some BooleanType, Some BooleanType, Some BooleanType) + | StrLess -> (Some StringType, Some StringType, Some BooleanType) + | And | Or | Impl -> (Some BooleanType, Some BooleanType, Some BooleanType) | StrCat -> (Some StringType, Some StringType, Some StringType) - | BSetMem -> (None, Some SetType, Some BooleanType) + | SetMem -> (None, Some SetType, Some BooleanType) | SetDiff -> (Some SetType, Some SetType, Some SetType) - | BSetSub -> (Some SetType, Some SetType, Some BooleanType) + | SetSub -> (Some SetType, Some SetType, Some BooleanType) | LstNth -> (Some ListType, Some IntType, None) | LstRepeat -> (None, Some IntType, Some ListType) | StrNth -> (Some ListType, Some NumberType, None) @@ -154,30 +153,7 @@ module Infer_types_to_gamma = struct tt = ListType && f le1 ListType && f le2 IntType && f le3 IntType | UnOp (op, le) -> infer_unop flag gamma new_gamma op le tt | BinOp (le1, op, le2) -> infer_binop flag gamma new_gamma op le1 le2 tt - | Exists (bt, le) -> - if not (tt = BooleanType) then false - else - let gamma_copy = Type_env.copy gamma in - let new_gamma_copy = Type_env.copy new_gamma in - let () = - List.iter - (fun (x, t) -> - let () = - match t with - | Some t -> Type_env.update gamma_copy x t - | None -> Type_env.remove gamma_copy x - in - Type_env.remove new_gamma_copy x) - bt - in - let ret = f' gamma_copy new_gamma_copy le BooleanType in - (* We've updated our new_gamma_copy with a bunch of things. - We need to import everything except the quantified variables to the new_gamma *) - Type_env.iter new_gamma_copy (fun x t -> - if not (List.exists (fun (y, _) -> String.equal x y) bt) then - Type_env.update new_gamma x t); - ret - | EForall (bt, le) -> + | Exists (bt, le) | ForAll (bt, le) -> if not (tt = BooleanType) then false else let gamma_copy = Type_env.copy gamma in @@ -245,10 +221,14 @@ let rec infer_types_expr gamma le : unit = | EList lle | ESet lle -> List.iter (fun le -> f le) lle | BinOp (le1, op, le2) -> ( match op with - | FPlus | FMinus | FTimes | FDiv | FMod -> + | Equal -> () + | And | Or | Impl -> + e le1 BooleanType; + e le2 BooleanType + | FPlus | FMinus | FTimes | FDiv | FMod | FLessThan | FLessThanEqual -> e le1 NumberType; e le2 NumberType - | IPlus | IMinus | ITimes | IDiv | IMod -> + | IPlus | IMinus | ITimes | IDiv | IMod | ILessThan | ILessThanEqual -> e le1 IntType; e le2 IntType | LstNth -> @@ -260,36 +240,23 @@ let rec infer_types_expr gamma le : unit = | StrNth -> e le1 StringType; e le2 NumberType + | StrLess -> + e le1 StringType; + e le2 StringType + | SetMem -> e le2 SetType + | SetSub | SetDiff -> + e le1 SetType; + e le2 SetType (* FIXME: Specify cases *) | _ -> ()) (* FIXME: Specify cases *) - | _ -> () - -let rec infer_types_formula (gamma : Type_env.t) (a : Formula.t) : unit = - let f = infer_types_formula gamma in - let e = safe_extend_gamma gamma in - - match a with - (* LForAll can be more precise *) - | True | False | ForAll _ -> () - | Not a -> f a - | And (a1, a2) | Or (a1, a2) -> - f a1; - f a2 - | FLess (e1, e2) | FLessEq (e1, e2) -> - e e1 NumberType; - e e2 NumberType - | ILess (e1, e2) | ILessEq (e1, e2) -> - e e1 IntType; - e e2 IntType - | StrLess (e1, e2) -> - e e1 StringType; - e e2 StringType - | SetMem (_, e2) -> e e2 SetType - | SetSub (e1, e2) -> - e e1 SetType; - e e2 SetType - (* FIXME: Specify cases *) + | UnOp (op, le) -> ( + match op with + | Not -> e le BooleanType + | IsInt | M_isNaN -> e le NumberType + | IUnaryMinus -> e le IntType + (* FIXME: Specify cases *) + | _ -> ()) | _ -> () (*****************) @@ -357,7 +324,7 @@ module Type_lexpr = struct let (tt : Type.t) = match op with | TypeOf -> TypeType - | UNot | M_isNaN -> BooleanType + | Not | M_isNaN | IsInt -> BooleanType | ToStringOp -> StringType | Car | Cdr -> ListType | LstRev | SetToList -> ListType @@ -406,12 +373,12 @@ module Type_lexpr = struct | ILessThanEqual | FLessThan | FLessThanEqual - | SLessThan - | BAnd - | BOr - | BImpl - | BSetMem - | BSetSub -> infer_type le BooleanType + | StrLess + | And + | Or + | Impl + | SetMem + | SetSub -> infer_type le BooleanType | SetDiff -> infer_type le SetType | StrCat -> infer_type le StringType | IPlus @@ -497,7 +464,7 @@ module Type_lexpr = struct | EList _ -> def_pos (Some ListType) (* Sets are always typable *) | ESet _ -> def_pos (Some SetType) - | Exists (bt, e) | EForall (bt, e) -> type_quantified_expr gamma le bt e + | Exists (bt, e) | ForAll (bt, e) -> type_quantified_expr gamma le bt e | UnOp (op, e) -> type_unop gamma le op e | BinOp (e1, op, e2) -> type_binop gamma le op e1 e2 | NOp (SetUnion, les) | NOp (SetInter, les) -> @@ -540,15 +507,16 @@ let te_of_list (vt : (Expr.t * Type.t) list) : Type_env.t option = let naively_infer_type_information (pfs : PFS.t) (gamma : Type_env.t) : unit = PFS.iter (fun a -> - match (a : Formula.t) with - | Eq (LVar x, le) | Eq (le, LVar x) -> + match (a : Expr.t) with + | Expr.BinOp (LVar x, Equal, le) | Expr.BinOp (le, Equal, LVar x) -> if not (Type_env.mem gamma x) then let le_type, _ = type_lexpr gamma le in Option.fold ~some:(fun x_type -> Type_env.update gamma x x_type) ~none:() le_type - | Eq (UnOp (TypeOf, LVar x), Lit (Type t)) - | Eq (Lit (Type t), UnOp (TypeOf, LVar x)) -> Type_env.update gamma x t + | Expr.BinOp (UnOp (TypeOf, LVar x), Equal, Lit (Type t)) + | Expr.BinOp (Lit (Type t), Equal, UnOp (TypeOf, LVar x)) -> + Type_env.update gamma x t | _ -> ()) pfs diff --git a/GillianCore/engine/FOLogic/typing.mli b/GillianCore/engine/FOLogic/typing.mli index 97456174..962ecc0d 100644 --- a/GillianCore/engine/FOLogic/typing.mli +++ b/GillianCore/engine/FOLogic/typing.mli @@ -9,7 +9,6 @@ val type_lexpr : Type_env.t -> Expr.t -> Type.t option * bool val infer_types_expr : Type_env.t -> Expr.t -> unit -val infer_types_formula : Type_env.t -> Formula.t -> unit val reverse_type_lexpr : bool -> Type_env.t -> (Expr.t * Type.t) list -> Type_env.t option From ad56f51085f0f806a09e607a3ae99d2f2db01afd Mon Sep 17 00:00:00 2001 From: N1ark Date: Tue, 24 Dec 2024 12:41:56 +0100 Subject: [PATCH 26/54] Update general_semantics/ --- .../engine/general_semantics/eSubst.ml | 63 ++----------------- .../general/g_interpreter.ml | 26 +++++--- GillianCore/engine/general_semantics/state.ml | 12 ++-- .../engine/general_semantics/stateErr.ml | 21 +++---- GillianCore/engine/general_semantics/subst.ml | 43 ++----------- 5 files changed, 40 insertions(+), 125 deletions(-) diff --git a/GillianCore/engine/general_semantics/eSubst.ml b/GillianCore/engine/general_semantics/eSubst.ml index b2936fe5..73db6e83 100644 --- a/GillianCore/engine/general_semantics/eSubst.ml +++ b/GillianCore/engine/general_semantics/eSubst.ml @@ -84,8 +84,6 @@ module type S = sig (** Optional substitution inside a logical expression *) val subst_in_expr_opt : t -> Expr.t -> Expr.t option - val substitute_formula : t -> partial:bool -> Formula.t -> Formula.t - val substitute_in_formula_opt : t -> Formula.t -> Formula.t option val substitute_asrt : t -> partial:bool -> Asrt.t -> Asrt.t val substitute_slcmd : t -> partial:bool -> SLCmd.t -> SLCmd.t val substitute_lcmd : t -> partial:bool -> LCmd.t -> LCmd.t @@ -421,7 +419,7 @@ module Make (Val : Val.S) : S with type vt = Val.t = struct Seq.iter (fun (x, le_x) -> put self_subst (LVar x) le_x) binder_substs; if new_expr == e then this else Exists (bt, new_expr) - method! visit_EForall () this bt e = + method! visit_ForAll () this bt e = let binders = List.to_seq bt |> Seq.map fst in let binder_substs = binders @@ -433,21 +431,7 @@ module Make (Val : Val.S) : S with type vt = Val.t = struct binders; let new_expr = self#visit_expr () e in Seq.iter (fun (x, le_x) -> put self_subst (LVar x) le_x) binder_substs; - if new_expr == e then this else EForall (bt, new_expr) - - method! visit_ForAll () this bt form = - let binders = List.to_seq bt |> Seq.map fst in - let binders_substs = - binders - |> Seq.filter_map (fun x -> - Option.map (fun x_v -> (x, x_v)) (get self_subst (LVar x))) - in - Seq.iter - (fun x -> put self_subst (LVar x) (Val.from_lvar_name x)) - binders; - let new_formula = self#visit_formula () form in - Seq.iter (fun (x, le_x) -> put self_subst (LVar x) le_x) binders_substs; - if new_formula == form then this else ForAll (bt, new_formula) + if new_expr == e then this else ForAll (bt, new_expr) end (** @@ -489,7 +473,7 @@ module Make (Val : Val.S) : S with type vt = Val.t = struct List.iter (fun (x, _) -> Hashtbl.remove subst (Expr.LVar x)) bt; let result = Option.map (fun e' -> Expr.Exists (bt, e')) e' in (result, false) - | EForall (bt, e) -> + | ForAll (bt, e) -> (* We use Hashtbl.add so that we can later remove the binding and recover the old one! *) List.iter (fun (x, _) -> @@ -499,7 +483,7 @@ module Make (Val : Val.S) : S with type vt = Val.t = struct bt; let e' = subst_in_expr_opt subst e in List.iter (fun (x, _) -> Hashtbl.remove subst (Expr.LVar x)) bt; - let result = Option.map (fun e' -> Expr.EForall (bt, e')) e' in + let result = Option.map (fun e' -> Expr.ForAll (bt, e')) e' in (result, false) | _ -> (Some le, true) in @@ -507,45 +491,6 @@ module Make (Val : Val.S) : S with type vt = Val.t = struct let is_empty (subst : t) : bool = Hashtbl.length subst = 0 - let substitute_formula (subst : t) ~(partial : bool) (a : Formula.t) : - Formula.t = - substitutor#init ~partial ~subst; - let res = substitutor#visit_formula () a in - substitutor#clear (); - res - - let substitute_in_formula_opt (subst : t) (a : Formula.t) : Formula.t option = - let open Formula in - let old_binders_substs = ref [] in - let f_before a = - match a with - | ForAll (bt, _) -> - let binders, _ = List.split bt in - let binders_substs = - List.map - (fun x -> Option.map (fun x_v -> (x, x_v)) (get subst (LVar x))) - binders - in - let binders_substs = - try List.filter_map (fun x -> x) binders_substs - with _ -> raise (Failure "DEATH. asrt_substitution") - in - old_binders_substs := binders_substs; - List.iter (fun x -> put subst (LVar x) (Val.from_lvar_name x)) binders; - (Some a, true) - | _ -> (Some a, true) - in - let f_after a = - match a with - | ForAll _ -> - List.iter - (fun (x, le_x) -> put subst (LVar x) le_x) - !old_binders_substs; - a - | _ -> a - in - map_opt (Some f_before) (Some f_after) (Some (subst_in_expr_opt subst)) a - let substitute_asrt (subst : t) ~(partial : bool) (a : Asrt.t) : Asrt.t = substitutor#init ~partial ~subst; let res = substitutor#visit_assertion () a in diff --git a/GillianCore/engine/general_semantics/general/g_interpreter.ml b/GillianCore/engine/general_semantics/general/g_interpreter.ml index 43253fe7..db98b455 100644 --- a/GillianCore/engine/general_semantics/general/g_interpreter.ml +++ b/GillianCore/engine/general_semantics/general/g_interpreter.ml @@ -486,13 +486,19 @@ struct let eval_assume f state = let store_subst = Store.to_ssubst (State.get_store state) in - let f' = SVal.SESubst.substitute_formula store_subst ~partial:true f in + let f' = SVal.SESubst.subst_in_expr store_subst ~partial:true f in (* Printf.printf "Assuming %s\n" (Formula.str f'); *) let open Syntaxes.List in let* f'', state = (* Sacha: I don't know why something different is happening in bi-exec *) if Exec_mode.is_biabduction_exec !Config.current_exec_mode then - let fos = Formula.get_disjuncts f' in + let fos = + let rec aux = function + | Expr.BinOp (e1, Or, e2) -> aux e1 @ aux e2 + | e -> [ e ] + in + aux f' + in match fos with | [] -> [] | [ f' ] -> [ (f', state) ] @@ -518,18 +524,18 @@ struct let eval_assert f state = let store_subst = Store.to_ssubst (State.get_store state) in - let f' = SVal.SESubst.substitute_formula store_subst ~partial:true f in + let f' = SVal.SESubst.subst_in_expr store_subst ~partial:true f in match State.assert_a state [ f' ] with | true -> Res_list.return state | false -> let err = StateErr.EPure f' in - let failing_model = State.sat_check_f state [ Not f' ] in + let failing_model = State.sat_check_f state [ Expr.Infix.not f' ] in let msg = Fmt.str "Assert failed with argument @[%a@].@\n\ @[Failing Model:@\n\ %a@]@\n" - Formula.pp f' + Expr.pp f' Fmt.(option ~none:(any "CANNOT CREATE MODEL") ESubst.pp) failing_model in @@ -544,7 +550,7 @@ struct | None -> Res_list.vanish in let right_states = - match State.assume_a state' [ Not fof ] with + match State.assume_a state' [ Expr.Infix.not fof ] with | Some state -> Res_list.return state | None -> Res_list.vanish in @@ -581,9 +587,9 @@ struct and eval_if e lcmds_t lcmds_e prog annot state eval_expr = let ve = eval_expr e in let e = Val.to_expr ve in - match Formula.lift_logic_expr e with - | Some (True, False) -> eval_lcmds prog lcmds_t ~annot state - | Some (False, True) -> eval_lcmds prog lcmds_e ~annot state + match Expr.as_boolean_expr e with + | Some (Expr.Lit (Bool true), _) -> eval_lcmds prog lcmds_t ~annot state + | Some (Expr.Lit (Bool false), _) -> eval_lcmds prog lcmds_e ~annot state | Some (foe, nfoe) -> let state' = State.copy state in let then_states = @@ -1252,7 +1258,7 @@ struct match lvt with | Some (Bool true) -> vfalse | Some (Bool false) -> vtrue - | _ -> eval_expr (UnOp (UNot, e)) + | _ -> eval_expr (Expr.Infix.not e) in L.verbose (fun fmt -> fmt "Evaluated expressions: %a, %a" Val.pp vt Val.pp vf); diff --git a/GillianCore/engine/general_semantics/state.ml b/GillianCore/engine/general_semantics/state.ml index 37ec1701..d20e9055 100644 --- a/GillianCore/engine/general_semantics/state.ml +++ b/GillianCore/engine/general_semantics/state.ml @@ -52,7 +52,7 @@ module type S = sig ?production:bool -> ?time:string -> t -> - Formula.t list -> + Expr.t list -> t option (** Assume type *) @@ -61,10 +61,10 @@ module type S = sig (** Satisfiability check *) val sat_check : t -> vt -> bool - val sat_check_f : t -> Formula.t list -> st option + val sat_check_f : t -> Expr.t list -> st option (** Assert assertion *) - val assert_a : t -> Formula.t list -> bool + val assert_a : t -> Expr.t list -> bool (** Value Equality *) val equals : t -> vt -> vt -> bool @@ -133,7 +133,7 @@ module type S = sig (t * Flag.t, err_t) Res_list.t val sure_is_nonempty : t -> bool - val unfolding_vals : t -> Formula.t list -> vt list + val unfolding_vals : t -> Expr.t list -> vt list val try_recovering : t -> vt Recovery_tactic.t -> (t list, string) result val substitution_in_place : ?subst_all:bool -> st -> t -> t list val clean_up : ?keep:Expr.Set.t -> t -> unit @@ -141,9 +141,9 @@ module type S = sig val produce_posts : t -> st -> Asrt.t list -> t list val produce : t -> st -> Asrt.t -> (t, err_t) Res_list.t val update_subst : t -> st -> unit - val mem_constraints : t -> Formula.t list + val mem_constraints : t -> Expr.t list val can_fix : err_t -> bool - val get_failing_constraint : err_t -> Formula.t + val get_failing_constraint : err_t -> Expr.t val get_fixes : err_t -> Asrt.t list val get_equal_values : t -> vt list -> vt list val get_heap : t -> heap_t diff --git a/GillianCore/engine/general_semantics/stateErr.ml b/GillianCore/engine/general_semantics/stateErr.ml index 732f26d2..7bdca364 100644 --- a/GillianCore/engine/general_semantics/stateErr.ml +++ b/GillianCore/engine/general_semantics/stateErr.ml @@ -5,9 +5,9 @@ type ('mem_err, 'value) t = | EMem of 'mem_err (** Memory error, depends on instantiation *) | EType of 'value * Type.t option * Type.t (** Incorrect type, depends on value *) - | EPure of Formula.t (* Missing formula that should be true *) + | EPure of Expr.t (* Missing formula that should be true *) | EVar of Var.t (* Undefined variable *) - | EAsrt of ('value list * Formula.t * Asrt.t list) + | EAsrt of ('value list * Expr.t * Asrt.t list) | EOther of string (* We want all errors to be proper errors - this is a temporary placeholder *) [@@deriving yojson, show] @@ -36,13 +36,13 @@ let pp_err Fmt.pf fmt "EType(%a, %a, %s)" pp_v v (Fmt.option ~none:(Fmt.any "None") (Fmt.of_to_string Type.str)) t1 (Type.str t2) - | EPure f -> Fmt.pf fmt "EPure(%a)" Formula.pp f + | EPure f -> Fmt.pf fmt "EPure(%a)" Expr.pp f | EVar x -> Fmt.pf fmt "EVar(%s)" x | EAsrt (vs, f, asrtss) -> let pp_asrts fmt asrts = Fmt.pf fmt "[%a]" Asrt.pp asrts in Fmt.pf fmt "EAsrt(%a; %a; %a)" (Fmt.list ~sep:(Fmt.any ", ") pp_v) - vs Formula.pp f + vs Expr.pp f (Fmt.list ~sep:(Fmt.any ", ") pp_asrts) asrtss | EOther msg -> Fmt.pf fmt "%s" msg @@ -50,16 +50,15 @@ let pp_err let can_fix (can_fix_mem : 'a -> bool) (err : ('a, 'b) t) : bool = match err with | EMem mem_err -> can_fix_mem mem_err - | EPure pf -> Reduction.reduce_formula pf <> False + | EPure pf -> Reduction.reduce_formula pf <> Expr.false_ | EAsrt (_, pf, _) -> - let result = Reduction.reduce_formula pf <> True in - Logging.verbose (fun fmt -> fmt "Can fix: %a: %b" Formula.pp pf result); + let result = Reduction.reduce_formula pf <> Expr.true_ in + Logging.verbose (fun fmt -> fmt "Can fix: %a: %b" Expr.pp pf result); result | _ -> false -let get_failing_constraint (err : ('a, 'b) t) (mem_fc : 'a -> Formula.t) : - Formula.t = +let get_failing_constraint (err : ('a, 'b) t) (mem_fc : 'a -> Expr.t) : Expr.t = match err with | EMem m_err -> mem_fc m_err - | EPure f -> Not f - | _ -> True + | EPure f -> Expr.Infix.not f + | _ -> Expr.true_ diff --git a/GillianCore/engine/general_semantics/subst.ml b/GillianCore/engine/general_semantics/subst.ml index 2648715a..48058da9 100644 --- a/GillianCore/engine/general_semantics/subst.ml +++ b/GillianCore/engine/general_semantics/subst.ml @@ -77,7 +77,6 @@ module type S = sig (** Optional substitution inside a logical expression *) val subst_in_expr_opt : t -> Expr.t -> Expr.t option - val substitute_formula : t -> partial:bool -> Formula.t -> Formula.t val substitute_asrt : t -> partial:bool -> Asrt.t -> Asrt.t val substitute_slcmd : t -> partial:bool -> SLCmd.t -> SLCmd.t val substitute_lcmd : t -> partial:bool -> LCmd.t -> LCmd.t @@ -324,6 +323,8 @@ module Make (Val : Val.S) : S with type vt = Val.t = struct generating fresh: %s" x lvar)); Expr.LVar lvar) + + (* Need to handle visit_ForAll ?? *) end in mapper#visit_expr () le @@ -345,48 +346,12 @@ module Make (Val : Val.S) : S with type vt = Val.t = struct let is_empty (subst : t) : bool = Hashtbl.length subst = 0 - let substitute_formula (subst : t) ~(partial : bool) : Formula.t -> Formula.t - = - let open Formula in - let old_binders_substs = ref [] in - let f_before a = - match a with - | ForAll (bt, _) -> - let binders, _ = List.split bt in - let binders_substs = - List.map - (fun x -> Option.map (fun x_v -> (x, x_v)) (get subst x)) - binders - in - let binders_substs = - try - List.map Option.get - (List.filter (fun x -> not (x = None)) binders_substs) - with _ -> raise (Failure "DEATH. asrt_substitution") - in - old_binders_substs := binders_substs; - List.iter (fun x -> put subst x (Val.from_lvar_name x)) binders; - (a, true) - | _ -> (a, true) - in - let f_after a = - match a with - | ForAll _ -> - List.iter (fun (x, le_x) -> put subst x le_x) !old_binders_substs; - a - | _ -> a - in - map (Some f_before) (Some f_after) (Some (subst_in_expr subst ~partial)) - let substitute_asrt (subst : t) ~(partial : bool) : Asrt.t -> Asrt.t = - Asrt.map (subst_in_expr subst ~partial) (substitute_formula subst ~partial) + Asrt.map (subst_in_expr subst ~partial) let substitute_slcmd (subst : t) ~(partial : bool) : SLCmd.t -> SLCmd.t = SLCmd.map (substitute_asrt subst ~partial) (subst_in_expr subst ~partial) let substitute_lcmd (subst : t) ~(partial : bool) : LCmd.t -> LCmd.t = - LCmd.map - (subst_in_expr subst ~partial) - (substitute_formula subst ~partial) - (substitute_slcmd subst ~partial) + LCmd.map (subst_in_expr subst ~partial) (substitute_slcmd subst ~partial) end From a278b5df7a83d6ab4b41ac434f169c22e7189ca1 Mon Sep 17 00:00:00 2001 From: N1ark Date: Tue, 24 Dec 2024 13:11:09 +0100 Subject: [PATCH 27/54] Update symbolic_semantics/ --- .../symbolic_semantics/Legacy_s_memory.ml | 21 ++---- .../engine/symbolic_semantics/SMemory.ml | 6 +- .../engine/symbolic_semantics/SState.ml | 68 +++++++++---------- .../engine/symbolic_semantics/SStore.ml | 5 +- .../engine/symbolic_semantics/SStore.mli | 2 +- 5 files changed, 45 insertions(+), 57 deletions(-) diff --git a/GillianCore/engine/symbolic_semantics/Legacy_s_memory.ml b/GillianCore/engine/symbolic_semantics/Legacy_s_memory.ml index d2317315..43b92eb9 100644 --- a/GillianCore/engine/symbolic_semantics/Legacy_s_memory.ml +++ b/GillianCore/engine/symbolic_semantics/Legacy_s_memory.ml @@ -4,18 +4,18 @@ module type S = sig type init_data (** Type of GIL values *) - type vt = SVal.M.t + type vt := SVal.M.t (** Type of GIL substitutions *) - type st = SVal.SESubst.t + type st := SVal.SESubst.t type err_t [@@deriving yojson, show] (** Type of GIL general states *) type t [@@deriving yojson] - type action_ret = - ( (t * vt list * Formula.t list * (string * Type.t) list) list, + type action_ret := + ( (t * vt list * Expr.t list * (string * Type.t) list) list, err_t list ) result @@ -54,16 +54,16 @@ module type S = sig gamma:Type_env.t -> st -> t -> - (t * Formula.Set.t * (string * Type.t) list) list + (t * Expr.Set.t * (string * Type.t) list) list val clean_up : ?keep:Expr.Set.t -> t -> Expr.Set.t * Expr.Set.t val lvars : t -> Containers.SS.t val alocs : t -> Containers.SS.t val assertions : ?to_keep:Containers.SS.t -> t -> Asrt.t - val mem_constraints : t -> Formula.t list + val mem_constraints : t -> Expr.t list val get_recovery_tactic : t -> err_t -> vt Recovery_tactic.t val pp_err : Format.formatter -> err_t -> unit - val get_failing_constraint : err_t -> Formula.t + val get_failing_constraint : err_t -> Expr.t val can_fix : err_t -> bool val get_fixes : err_t -> Asrt.t list val sure_is_nonempty : t -> bool @@ -71,16 +71,9 @@ end module Dummy : S with type init_data = unit = struct type init_data = unit - type vt = SVal.M.t - type st = SVal.SESubst.t type err_t = unit [@@deriving yojson, show] type t = unit [@@deriving yojson] - type action_ret = - ( (t * vt list * Formula.t list * (string * Type.t) list) list, - err_t list ) - result - let init () = () let get_init_data () = () let clear () = () diff --git a/GillianCore/engine/symbolic_semantics/SMemory.ml b/GillianCore/engine/symbolic_semantics/SMemory.ml index 86267bea..2d68466e 100644 --- a/GillianCore/engine/symbolic_semantics/SMemory.ml +++ b/GillianCore/engine/symbolic_semantics/SMemory.ml @@ -49,16 +49,16 @@ module type S = sig gamma:Type_env.t -> st -> t -> - (t * Formula.Set.t * (string * Type.t) list) list + (t * Expr.Set.t * (string * Type.t) list) list val clean_up : ?keep:Expr.Set.t -> t -> Expr.Set.t * Expr.Set.t val lvars : t -> Containers.SS.t val alocs : t -> Containers.SS.t val assertions : ?to_keep:Containers.SS.t -> t -> Asrt.t - val mem_constraints : t -> Formula.t list + val mem_constraints : t -> Expr.t list val get_recovery_tactic : t -> err_t -> vt Recovery_tactic.t val pp_err : Format.formatter -> err_t -> unit - val get_failing_constraint : err_t -> Formula.t + val get_failing_constraint : err_t -> Expr.t val get_fixes : err_t -> Asrt.t list val can_fix : err_t -> bool val sure_is_nonempty : t -> bool diff --git a/GillianCore/engine/symbolic_semantics/SState.ml b/GillianCore/engine/symbolic_semantics/SState.ml index 0dc1854e..e4852140 100644 --- a/GillianCore/engine/symbolic_semantics/SState.ml +++ b/GillianCore/engine/symbolic_semantics/SState.ml @@ -252,7 +252,7 @@ module Make (SMemory : SMemory.S) : | LstSub (e1, e2, e3) -> LstSub (f e1, f e2, f e3) (* Exists. We can just evaluate pvars because they cannot be quantified *) | Exists (bt, e) -> Exists (bt, f e) - | EForall (bt, e) -> EForall (bt, f e) + | ForAll (bt, e) -> ForAll (bt, f e) | Lit _ | LVar _ | ALoc _ -> expr in (* Perform reduction *) @@ -277,14 +277,15 @@ module Make (SMemory : SMemory.S) : | Lit (Bool false) -> [ state ] | _ -> (* let t = time() in *) + let red = + Expr.as_boolean_expr @@ Reduction.reduce_lexpr ~pfs ~gamma v + in let v_asrt = - match - Formula.lift_logic_expr (Reduction.reduce_lexpr ~pfs ~gamma v) - with + match red with | Some (v_asrt, _) -> v_asrt - | _ -> False + | _ -> Lit (Bool false) in - if v_asrt = False then [] + if v_asrt = Lit (Bool false) then [] else ( PFS.extend pfs v_asrt; [ state ]) @@ -296,7 +297,7 @@ module Make (SMemory : SMemory.S) : ?(production = false) ?(time = "") (state : t) - (ps : Formula.t list) : t option = + (ps : Expr.t list) : t option = let { pfs; gamma; _ } = state in try let ps = @@ -319,14 +320,14 @@ module Make (SMemory : SMemory.S) : Some state) else ( Logging.verbose (fun m -> - m "assume_a: Couldn't assume %a" (Fmt.Dump.list Formula.pp) ps); + m "assume_a: Couldn't assume %a" (Fmt.Dump.list Expr.pp) ps); None) in result with Reduction.ReductionException (e, msg) -> Logging.verbose (fun m -> m "assume_a: Couldn't assume due to an error reducing %a - %s\nps: %a" - Expr.pp e msg (Fmt.Dump.list Formula.pp) ps); + Expr.pp e msg (Fmt.Dump.list Expr.pp) ps); None let assume_t ({ gamma; _ } as state : t) (v : vt) (t : Type.t) : t option = @@ -343,9 +344,9 @@ module Make (SMemory : SMemory.S) : else if v = Lit (Bool false) then false else let v_asrt = - match Formula.lift_logic_expr v with + match Expr.as_boolean_expr v with | Some (v_asrt, _) -> v_asrt - | _ -> False + | _ -> Lit (Bool false) in let relevant_info = (Expr.pvars v, Expr.lvars v, Expr.locs v) in let result = @@ -356,10 +357,10 @@ module Make (SMemory : SMemory.S) : L.(verbose (fun m -> m "SState: sat_check done: %b" result)); result - let sat_check_f ({ pfs; gamma; _ } : t) (fs : Formula.t list) : st option = + let sat_check_f ({ pfs; gamma; _ } : t) (fs : Expr.t list) : st option = FOSolver.check_satisfiability_with_model (fs @ PFS.to_list pfs) gamma - let assert_a ({ pfs; gamma; _ } : t) (ps : Formula.t list) : bool = + let assert_a ({ pfs; gamma; _ } : t) (ps : Expr.t list) : bool = FOSolver.check_entailment SS.empty pfs ps gamma let equals ({ pfs; gamma; _ } : t) (le1 : vt) (le2 : vt) : bool = @@ -432,7 +433,7 @@ module Make (SMemory : SMemory.S) : match memories with | [] -> failwith "Impossible: memory substitution returned []" | [ (mem, lpfs, lgamma) ] -> - let () = Formula.Set.iter (PFS.extend pfs) lpfs in + let () = Expr.Set.iter (PFS.extend pfs) lpfs in let () = List.iter (fun (t, v) -> Type_env.update gamma t v) lgamma in @@ -444,7 +445,7 @@ module Make (SMemory : SMemory.S) : (fun (mem, lpfs, lgamma) -> let bpfs = PFS.copy pfs in let bgamma = Type_env.copy gamma in - let () = Formula.Set.iter (PFS.extend bpfs) lpfs in + let () = Expr.Set.iter (PFS.extend bpfs) lpfs in let () = List.iter (fun (t, v) -> Type_env.update bgamma t v) lgamma in @@ -551,22 +552,15 @@ module Make (SMemory : SMemory.S) : (_ : (string * (string * vt) list) option) = raise (Failure "ERROR: run_spec called for non-abstract execution") - let unfolding_vals (_ : t) (fs : Formula.t list) : vt list = - let lvars = - SS.of_list - (List.concat (List.map (fun f -> SS.elements (Formula.lvars f)) fs)) - in - let alocs = - SS.of_list - (List.concat (List.map (fun f -> SS.elements (Formula.alocs f)) fs)) - in - let clocs = - SS.of_list - (List.concat (List.map (fun f -> SS.elements (Formula.clocs f)) fs)) + let unfolding_vals (_ : t) (fs : Expr.t list) : vt list = + let map to_str to_expr = + List.map to_str fs + |> List.fold_left SS.union SS.empty + |> SS.elements |> List.map to_expr in - let lvars = List.map (fun x -> Expr.LVar x) (SS.elements lvars) in - let alocs = List.map (fun x -> Expr.ALoc x) (SS.elements alocs) in - let clocs = List.map (fun x -> Expr.Lit (Loc x)) (SS.elements clocs) in + let lvars = map Expr.lvars (fun x -> Expr.LVar x) in + let alocs = map Expr.alocs (fun x -> Expr.ALoc x) in + let clocs = map Expr.clocs (fun x -> Expr.Lit (Loc x)) in clocs @ alocs @ lvars let substitution_in_place ?(subst_all = false) (subst : st) (state : t) : @@ -581,7 +575,7 @@ module Make (SMemory : SMemory.S) : match SMemory.substitution_in_place ~pfs ~gamma subst heap with | [] -> failwith "IMPOSSIBLE: SMemory always returns at least one memory" | [ (mem, lpfs, lgamma) ] -> - let () = Formula.Set.iter (PFS.extend pfs) lpfs in + let () = Expr.Set.iter (PFS.extend pfs) lpfs in let () = List.iter (fun (t, v) -> Type_env.update gamma t v) lgamma in [ { heap = mem; store; pfs; gamma; spec_vars } ] | multi_mems -> @@ -589,7 +583,7 @@ module Make (SMemory : SMemory.S) : (fun (mem, lpfs, lgamma) -> let bpfs = PFS.copy pfs in let bgamma = Type_env.copy gamma in - let () = Formula.Set.iter (PFS.extend bpfs) lpfs in + let () = Expr.Set.iter (PFS.extend bpfs) lpfs in let () = List.iter (fun (t, v) -> Type_env.update bgamma t v) lgamma in @@ -672,7 +666,7 @@ module Make (SMemory : SMemory.S) : | None -> ALoc (ALoc.alloc ())) | None -> ALoc (ALoc.alloc ()) - let mem_constraints ({ heap; _ } : t) : Formula.t list = + let mem_constraints ({ heap; _ } : t) : Expr.t list = SMemory.mem_constraints heap let get_recovery_tactic (state : t) (errs : err_t list) : vt Recovery_tactic.t @@ -684,9 +678,9 @@ module Make (SMemory : SMemory.S) : if Recovery_tactic.is_none memory_tactic then memory_tactic else PFS.fold_left - (fun (acc : vt Recovery_tactic.t) pf -> - match pf with - | Eq ((ALoc _ as loc), LVar x) | Eq (LVar x, (ALoc _ as loc)) -> + (fun (acc : vt Recovery_tactic.t) -> function + | BinOp ((ALoc _ as loc), Equal, LVar x) + | BinOp (LVar x, Equal, (ALoc _ as loc)) -> if Names.is_spec_var_name x then let try_fold = Option.map @@ -709,7 +703,7 @@ module Make (SMemory : SMemory.S) : let pp_err = StateErr.pp_err SMemory.pp_err SVal.M.pp let can_fix = StateErr.can_fix SMemory.can_fix - let get_failing_constraint (err : err_t) : Formula.t = + let get_failing_constraint (err : err_t) : Expr.t = StateErr.get_failing_constraint err SMemory.get_failing_constraint (* get_fixes returns a list of possible fixes. diff --git a/GillianCore/engine/symbolic_semantics/SStore.ml b/GillianCore/engine/symbolic_semantics/SStore.ml index 0351c7aa..5c56ddce 100644 --- a/GillianCore/engine/symbolic_semantics/SStore.ml +++ b/GillianCore/engine/symbolic_semantics/SStore.ml @@ -32,9 +32,10 @@ let clocs (x : t) : SS.t = fold x (fun _ le ac -> SS.union ac (Expr.clocs le)) SS.empty (** conversts a symbolic store to a list of assertions *) -let assertions (x : t) : Formula.t list = +let assertions (x : t) : Expr.t list = fold x - (fun x le (assertions : Formula.t list) -> Eq (PVar x, le) :: assertions) + (fun x le (assertions : Expr.t list) -> + Expr.BinOp (PVar x, Equal, le) :: assertions) [] let is_well_formed (_ : t) : bool = true diff --git a/GillianCore/engine/symbolic_semantics/SStore.mli b/GillianCore/engine/symbolic_semantics/SStore.mli index 01c1392e..089b75c4 100644 --- a/GillianCore/engine/symbolic_semantics/SStore.mli +++ b/GillianCore/engine/symbolic_semantics/SStore.mli @@ -24,7 +24,7 @@ val vars : t -> Var.Set.t val lvars : t -> Var.Set.t val clocs : t -> Var.Set.t val alocs : t -> Var.Set.t -val assertions : t -> Formula.t list +val assertions : t -> Expr.t list val substitution_in_place : ?subst_all:bool -> SVal.SESubst.t -> t -> unit val is_well_formed : t -> bool val bindings : t -> (Var.t * vt) list From 4368ddde054dbd7d8429a95eb8430aed1b4e29ad Mon Sep 17 00:00:00 2001 From: N1ark Date: Tue, 24 Dec 2024 14:35:46 +0100 Subject: [PATCH 28/54] Update concrete_semantics/ --- .../engine/concrete_semantics/CExprEval.ml | 667 ++++++------------ .../engine/concrete_semantics/CState.ml | 32 +- 2 files changed, 223 insertions(+), 476 deletions(-) diff --git a/GillianCore/engine/concrete_semantics/CExprEval.ml b/GillianCore/engine/concrete_semantics/CExprEval.ml index 8ce5e890..8cab77b7 100644 --- a/GillianCore/engine/concrete_semantics/CExprEval.ml +++ b/GillianCore/engine/concrete_semantics/CExprEval.ml @@ -6,259 +6,155 @@ module CStore = Store.Make (CVal.M) exception TypeError of string exception EvaluationError of string -let unary_int_thing (lit : CVal.M.t) (f : Z.t -> Z.t) emsg : CVal.M.t = - let num = - match lit with - | Int n -> n - | _ -> raise (TypeError (Fmt.str "%s %a" emsg CVal.M.pp lit)) - in +let evalerr msg = raise (EvaluationError (Fmt.str "Evaluation Error: %s" msg)) + +let typeerr typ lit = + raise (TypeError (Fmt.str "Expected %s, got %a" typ Literal.pp lit)) + +let as_str = function + | Literal.String s -> s + | lit -> typeerr "string" lit + +let as_bool = function + | Literal.Bool b -> b + | lit -> typeerr "boolean" lit + +let as_int = function + | Literal.Int i -> i + | lit -> typeerr "integer" lit + +let as_num = function + | Literal.Num n -> n + | lit -> typeerr "number" lit + +let as_list = function + | Literal.LList l -> l + | lit -> typeerr "list" lit + +let unary_int_thing (lit : CVal.M.t) (f : Z.t -> Z.t) : CVal.M.t = + let num = as_int lit in let res = f num in Int res -let unary_num_thing (lit : CVal.M.t) (f : float -> float) emsg : CVal.M.t = - let num = - match lit with - | Num n -> n - | _ -> raise (TypeError (Fmt.str "%s %a" emsg CVal.M.pp lit)) - in +let unary_num_thing (lit : CVal.M.t) (f : float -> float) : CVal.M.t = + let num = as_num lit in let res = f num in Num res let evaluate_unop (op : UnOp.t) (lit : CVal.M.t) : CVal.M.t = match op with - | UNot -> ( - match (lit : CVal.M.t) with - | Bool b -> Bool (not b) - | _ -> - raise - (TypeError - (Fmt.str "Type Error: Negation: expected boolean, got %a" - CVal.M.pp lit))) - | IUnaryMinus -> - unary_int_thing lit - (fun x -> Z.neg x) - "Type Error: Integer unary minus: expected integer, got " - | FUnaryMinus -> - unary_num_thing lit - (fun x -> -.x) - "Type Error: Float unary minus: expected float, got " - | BitwiseNot -> - unary_num_thing lit int32_bitwise_not - "Type Error: Bitwise not: expected number, got" - | M_abs -> - unary_num_thing lit abs_float - "Type Error: Absolute value: expected number, got" - | M_acos -> - unary_num_thing lit acos "Type Error: Arc cosine: expected number, got" - | M_asin -> - unary_num_thing lit asin "Type Error: Arc sine: expected number, got" - | M_atan -> - unary_num_thing lit atan "Type Error: Arc tangent: expected number, got" - | M_ceil -> - unary_num_thing lit ceil "Type Error: Ceiling: expected number, got" - | M_cos -> unary_num_thing lit cos "Type Error: Cosine: expected number, got" - | M_exp -> - unary_num_thing lit exp "Type Error: Exponentiation: expected number, got" - | M_floor -> - unary_num_thing lit floor "Type Error: Floor: expected number, got" - | M_log -> - unary_num_thing lit log "Type Error: Unary minus: expected number, got" + | Not -> + let b = as_bool lit in + Bool (not b) + | IUnaryMinus -> unary_int_thing lit (fun x -> Z.neg x) + | FUnaryMinus -> unary_num_thing lit (fun x -> -.x) + | BitwiseNot -> unary_num_thing lit int32_bitwise_not + | M_abs -> unary_num_thing lit abs_float + | M_acos -> unary_num_thing lit acos + | M_asin -> unary_num_thing lit asin + | M_atan -> unary_num_thing lit atan + | M_ceil -> unary_num_thing lit ceil + | M_cos -> unary_num_thing lit cos + | M_exp -> unary_num_thing lit exp + | M_floor -> unary_num_thing lit floor + | M_log -> unary_num_thing lit log | M_round -> ( - match lit with - | Num n -> ( - let sign = copysign 1.0 n in - match sign < 0.0 && n >= -0.5 with - | true -> Num (-0.0) - | _ -> - (* This complex rounding is needed for edge case in OCaml: 0.49999999999999994 *) - let round_nearest_lb = -.(2. ** 52.) in - let round_nearest_ub = 2. ** 52. in - - let round_nearest t = - if t >= round_nearest_lb && t <= round_nearest_ub then - floor (t +. 0.49999999999999994) - else t - in - Num (round_nearest n)) + let n = as_num lit in + let sign = copysign 1.0 n in + match sign < 0.0 && n >= -0.5 with + | true -> Num (-0.0) | _ -> - raise - (TypeError - (Fmt.str "Type Error: Round: expected number, got %a" CVal.M.pp - lit))) - | M_sgn -> - unary_num_thing lit - (fun x -> copysign 1.0 x) - "Type Error: Sign: expected number, got" - | M_sin -> unary_num_thing lit sin "Type Error: Sine: expected number, got" - | M_sqrt -> - unary_num_thing lit sqrt "Type Error: Square root: expected number, got" - | M_tan -> unary_num_thing lit tan "Type Error: Tangent: expected number, got" - | ToStringOp -> ( - match lit with - | Num n -> String (float_to_string_inner n) - | _ -> - raise - (TypeError - (Fmt.str "Type Error: Number to string: expected number, got %a" - CVal.M.pp lit))) - | ToIntOp -> - unary_num_thing lit to_int - "Type Error: Number to integer: expected number, got" - | ToUint16Op -> - unary_num_thing lit to_uint16 - "Type Error: Number to unsigned 16-bit integer: expected number, got" - | ToInt32Op -> - unary_num_thing lit to_int32 - "Type Error: Number to 32-bit integer: expected number, got" - | ToUint32Op -> - unary_num_thing lit to_uint32 - "Type Error: Number to unsigned 32-bit integer: expected number, got" - | ToNumberOp -> ( - match lit with - | String s -> - if s = "" then Num 0. - else - let num = try Float.of_string s with Failure _ -> nan in - Num num - | _ -> - raise - (TypeError - (Fmt.str "Type Error: ToNumber: expected string, got %a" - CVal.M.pp lit))) - | IntToNum -> ( - match lit with - | Int x -> Num (Z.to_float x) - | _ -> - raise - (TypeError - (Fmt.str "Type Error: IntToNum: expected integer, got %a" - CVal.M.pp lit))) - | NumToInt -> ( - match lit with - | Num x -> Int (Z.of_float x) - | _ -> - raise - (TypeError - (Fmt.str "Type Error: NumToInt: expected number, got %a" - CVal.M.pp lit))) + (* This complex rounding is needed for edge case in OCaml: 0.49999999999999994 *) + let round_nearest_lb = -.(2. ** 52.) in + let round_nearest_ub = 2. ** 52. in + + let round_nearest t = + if t >= round_nearest_lb && t <= round_nearest_ub then + floor (t +. 0.49999999999999994) + else t + in + Num (round_nearest n)) + | M_sgn -> unary_num_thing lit (fun x -> copysign 1.0 x) + | M_sin -> unary_num_thing lit sin + | M_sqrt -> unary_num_thing lit sqrt + | M_tan -> unary_num_thing lit tan + | ToStringOp -> + let n = as_num lit in + String (float_to_string_inner n) + | ToIntOp -> unary_num_thing lit to_int + | ToUint16Op -> unary_num_thing lit to_uint16 + | ToInt32Op -> unary_num_thing lit to_int32 + | ToUint32Op -> unary_num_thing lit to_uint32 + | ToNumberOp -> + let s = as_str lit in + if s = "" then Num 0. + else + let num = try Float.of_string s with Failure _ -> nan in + Num num + | IntToNum -> + let x = as_int lit in + Num (Z.to_float x) + | NumToInt -> + let x = as_num lit in + Int (Z.of_float x) | TypeOf -> Type (Literal.type_of lit) | Car -> ( - match lit with - | LList ll -> ( - match ll with - | [] -> - raise - (EvaluationError "Evaluation Error: List head of empty list") - | lit :: _ -> lit) - | _ -> - raise - (TypeError - (Fmt.str "Type Error: List head: expected list, got %a" CVal.M.pp - lit))) + let ll = as_list lit in + match ll with + | [] -> evalerr "List head of empty list" + | lit :: _ -> lit) | Cdr -> ( - match lit with - | LList ll -> ( - match ll with - | [] -> - raise - (EvaluationError "Evaluation Error: List tail of empty list") - | _ :: ll -> LList ll) - | _ -> - raise - (TypeError - (Fmt.str "Type Error: List tail: expected list, got %a" CVal.M.pp - lit))) - | LstLen -> ( - match lit with - | LList l -> Int (Z.of_int (List.length l)) - | _ -> - raise - (TypeError - (Fmt.str "Type Error: List length: expected list, got: %a" - CVal.M.pp lit))) - | LstRev -> ( - match lit with - | LList l -> LList (List.rev l) - | _ -> - raise - (TypeError - (Fmt.str "Type Error: List reverse: expected list, got: %a" - CVal.M.pp lit))) - | StrLen -> ( - match lit with - | String s -> Num (float_of_int (String.length s)) - | _ -> - raise - (TypeError - (Fmt.str "Type Error: String length: expected string, got: %a" - CVal.M.pp lit))) - | M_isNaN -> ( - match lit with - | Num x when x == nan -> Bool true - | Num _ -> Bool false - | _ -> - raise - (TypeError - (Fmt.str "Type Error: M_isNan: expected number, got: %a" - CVal.M.pp lit))) + let ll = as_list lit in + match ll with + | [] -> evalerr "List tail of empty list" + | _ :: ll -> LList ll) + | LstLen -> + let ll = as_list lit in + Int (Z.of_int (List.length ll)) + | LstRev -> + let ll = as_list lit in + LList (List.rev ll) + | StrLen -> + let s = as_str lit in + Num (float_of_int (String.length s)) + | M_isNaN -> + let x = as_num lit in + Bool (x <> x) | SetToList -> raise (Exceptions.Unsupported "eval_unop concrete: set-to-list") + | IsInt -> + let x = as_num lit in + Bool (is_int x) let binary_num_thing (lit1 : CVal.M.t) (lit2 : CVal.M.t) - (f : float -> float -> float) - emsg : CVal.M.t = - let num1, num2 = - match (lit1, lit2) with - | Num n1, Num n2 -> (n1, n2) - | _ -> - raise - (TypeError (Fmt.str "%s %a and %a" emsg CVal.M.pp lit1 CVal.M.pp lit2)) - in - Num (f num1 num2) + (f : float -> float -> float) = + let num1 = as_num lit1 in + let num2 = as_num lit2 in + Literal.Num (f num1 num2) -let binary_int_thing - (lit1 : CVal.M.t) - (lit2 : CVal.M.t) - (f : Z.t -> Z.t -> Z.t) - emsg : CVal.M.t = - let num1, num2 = - match (lit1, lit2) with - | Int n1, Int n2 -> (n1, n2) - | _ -> - raise - (TypeError (Fmt.str "%s %a and %a" emsg CVal.M.pp lit1 CVal.M.pp lit2)) - in - Int (f num1 num2) +let binary_int_thing (lit1 : CVal.M.t) (lit2 : CVal.M.t) (f : Z.t -> Z.t -> Z.t) + = + let num1 = as_int lit1 in + let num2 = as_int lit2 in + Literal.Int (f num1 num2) let binary_int_bool_thing (lit1 : CVal.M.t) (lit2 : CVal.M.t) - (f : Z.t -> Z.t -> bool) - emsg : CVal.M.t = - let num1, num2 = - match (lit1, lit2) with - | Int n1, Int n2 -> (n1, n2) - | _ -> - raise - (TypeError (Fmt.str "%s %a and %a" emsg CVal.M.pp lit1 CVal.M.pp lit2)) - in - Bool (f num1 num2) + (f : Z.t -> Z.t -> bool) = + let num1 = as_int lit1 in + let num2 = as_int lit2 in + Literal.Bool (f num1 num2) let binary_num_bool_thing (lit1 : CVal.M.t) (lit2 : CVal.M.t) - (f : float -> float -> bool) - emsg : CVal.M.t = - let num1, num2 = - match (lit1, lit2) with - | Num n1, Num n2 -> (n1, n2) - | _ -> - raise - (TypeError (Fmt.str "%s %a and %a" emsg CVal.M.pp lit1 CVal.M.pp lit2)) - in - Bool (f num1 num2) + (f : float -> float -> bool) = + let num1 = as_num lit1 in + let num2 = as_num lit2 in + Literal.Bool (f num1 num2) let rec evaluate_binop (store : CStore.t) @@ -268,46 +164,25 @@ let rec evaluate_binop let ee = evaluate_expr store in let lit1 = ee e1 in match op with - | BImpl -> ee (BinOp (UnOp (UNot, Expr.Lit lit1), BOr, e2)) - | BAnd -> ( - match lit1 with - | Bool false -> Bool false - | Bool true -> ( - match ee e2 with - | Bool b2 -> Bool b2 - | lit2 -> - raise - (TypeError - (Fmt.str "Type Error: Conjunction: expected boolean, got: %a" - CVal.M.pp lit2))) - | _ -> - raise - (TypeError - (Fmt.str "Type Error: Conjunction: expected boolean, got: %a" - CVal.M.pp lit1))) - | BOr -> ( - match lit1 with - | Bool true -> Bool true - | Bool false -> ( - let lit2 = ee e2 in - match lit2 with - | Bool b2 -> Bool b2 - | _ -> - raise - (TypeError - (Fmt.str "Type Error: Disjunction: expected boolean, got: %a" - CVal.M.pp lit2))) - | _ -> - raise - (TypeError - (Fmt.str "Type Error: Disjunction: expected boolean, got: %a" - CVal.M.pp lit1))) + | Impl -> ee (BinOp (UnOp (Not, Expr.Lit lit1), Or, e2)) + | And -> + let b1 = as_bool lit1 in + if not b1 then Bool false + else + let b2 = as_bool @@ ee e2 in + Bool b2 + | Or -> + let b1 = as_bool lit1 in + if b1 then Bool true + else + let b2 = as_bool @@ ee e2 in + Bool b2 | _ -> ( let lit2 = ee e2 in match op with - | SetDiff | BSetMem | BSetSub -> + | SetDiff | SetMem | SetSub -> raise (Exceptions.Unsupported "eval_binop concrete: set operator") - | BOr | BAnd | BImpl -> + | Or | And | Impl -> raise (Exceptions.Impossible "eval_binop concrete: by construction") | Equal -> ( match (lit1, lit2) with @@ -325,198 +200,85 @@ let rec evaluate_binop | Nono, Nono -> Bool true | _, _ -> Bool false) | LstNth -> ( - match (lit1, lit2) with - | LList list, Int n -> List.nth list (Z.to_int n) - | LList list, Num n when is_int n -> List.nth list (int_of_float n) - | LList list, Num -0. -> List.nth list 0 - | _, _ -> - raise - (TypeError - (Fmt.str - "Type Error: List indexing: expected list and number, \ - got %a and %a" - CVal.M.pp lit1 CVal.M.pp lit2))) - | LstRepeat -> ( + let list = as_list lit1 in match lit2 with - | Int n -> - let n = Z.to_int n in - let elements = List.init n (fun _ -> lit1) in - LList elements - | _ -> - raise - (TypeError - (Fmt.str "Type Error: List repeat: expected integer, got %a" - CVal.M.pp lit2))) + | Int n -> List.nth list (Z.to_int n) + | Num n when is_int n -> List.nth list (int_of_float n) + | Num -0. -> List.nth list 0 + | _ -> typeerr "integer or number" lit2) + | LstRepeat -> + let n = as_int lit2 in + let n = Z.to_int n in + let elements = List.init n (fun _ -> lit1) in + LList elements | StrNth -> ( - match (lit1, lit2) with - | String s, Num n when is_int n -> - String (String.make 1 s.[int_of_float n]) - | String s, Num -0. -> String (String.make 1 s.[0]) - | _, _ -> - raise - (TypeError - (Fmt.str - "Type Error: List indexing: expected string and number, \ - got %a and %a" - CVal.M.pp lit1 CVal.M.pp lit2))) - | ILessThan -> - binary_int_bool_thing lit1 lit2 - (fun x y -> x < y) - "Type Error: Less than: expected integers, got " - | FLessThan -> - binary_num_bool_thing lit1 lit2 - (fun x y -> x < y) - "Type Error: Less than: expected numbers, got " - | SLessThan -> ( - match (lit1, lit2) with - | String s1, String s2 -> Bool (s1 < s2) - | _, _ -> raise (Failure "Non-string arguments to LessThanString")) - | ILessThanEqual -> - binary_int_bool_thing lit1 lit2 - (fun x y -> x <= y) - "Type Error: Less than or equal: expected integers, got " - | FLessThanEqual -> - binary_num_bool_thing lit1 lit2 - (fun x y -> x <= y) - "Type Error: Less than or equal: expected numbers, got " - | IPlus -> - binary_int_thing lit1 lit2 Z.add - "Type Error: Integer Addition: expected integers, got " - | IMinus -> - binary_int_thing lit1 lit2 Z.sub - "Type Error: Subtraction: expected integers, got " - | ITimes -> - binary_int_thing lit1 lit2 Z.mul - "Type Error: Multiplication: expected integers, got " - | IDiv -> - binary_int_thing lit1 lit2 Z.div - "Type Error: Division: expected integers, got " - | IMod -> - binary_int_thing lit1 lit2 Z.( mod ) - "Type Error: IModulus: expected ints, got " - | FPlus -> - binary_num_thing lit1 lit2 - (fun x y -> x +. y) - "Type Error: Addition: expected numbers, got " - | FMinus -> - binary_num_thing lit1 lit2 - (fun x y -> x -. y) - "Type Error: Subtraction: expected numbers, got " - | FTimes -> - binary_num_thing lit1 lit2 - (fun x y -> x *. y) - "Type Error: Multiplication: expected numbers, got " - | FDiv -> - binary_num_thing lit1 lit2 - (fun x y -> x /. y) - "Type Error: Division: expected numbers, got " - | FMod -> - binary_num_thing lit1 lit2 mod_float - "Type Error: FModulus: expected numbers, got " - | BitwiseAnd -> - binary_int_thing lit1 lit2 Z.logand - "Type Error: Bitwise conjunction: expected numbers, got " - | BitwiseOr -> - binary_int_thing lit1 lit2 Z.logor - "Type Error: Bitwise disjunction: expected numbers, got " - | BitwiseXor -> - binary_int_thing lit1 lit2 Z.logxor - "Type Error: Bitwise exclusive disjunction: expected numbers, got " + let s = as_str lit1 in + match lit2 with + | Num n when is_int n -> String (String.make 1 s.[int_of_float n]) + | Num -0. -> String (String.make 1 s.[0]) + | _ -> typeerr "number" lit2) + | ILessThan -> binary_int_bool_thing lit1 lit2 (fun x y -> x < y) + | FLessThan -> binary_num_bool_thing lit1 lit2 (fun x y -> x < y) + | StrLess -> + let s1 = as_str lit1 in + let s2 = as_str lit2 in + Bool (s1 < s2) + | ILessThanEqual -> binary_int_bool_thing lit1 lit2 (fun x y -> x <= y) + | FLessThanEqual -> binary_num_bool_thing lit1 lit2 (fun x y -> x <= y) + | IPlus -> binary_int_thing lit1 lit2 Z.add + | IMinus -> binary_int_thing lit1 lit2 Z.sub + | ITimes -> binary_int_thing lit1 lit2 Z.mul + | IDiv -> binary_int_thing lit1 lit2 Z.div + | IMod -> binary_int_thing lit1 lit2 Z.( mod ) + | FPlus -> binary_num_thing lit1 lit2 ( +. ) + | FMinus -> binary_num_thing lit1 lit2 ( -. ) + | FTimes -> binary_num_thing lit1 lit2 ( *. ) + | FDiv -> binary_num_thing lit1 lit2 ( /. ) + | FMod -> binary_num_thing lit1 lit2 mod_float + | BitwiseAnd -> binary_int_thing lit1 lit2 Z.logand + | BitwiseOr -> binary_int_thing lit1 lit2 Z.logor + | BitwiseXor -> binary_int_thing lit1 lit2 Z.logxor | LeftShift -> - binary_int_thing lit1 lit2 - (fun x y -> Z.shift_left x (Z.to_int y)) - "Type Error: Left shift: expected numbers, got " + binary_int_thing lit1 lit2 (fun x y -> Z.shift_left x (Z.to_int y)) | SignedRightShift -> - binary_int_thing lit1 lit2 - (fun x y -> Z.shift_right x (Z.to_int y)) - "Type Error: Signed right shift: expected numbers, got " + binary_int_thing lit1 lit2 (fun x y -> Z.shift_right x (Z.to_int y)) | UnsignedRightShift -> - binary_int_thing lit1 lit2 - (fun x y -> Z.shift_right x (Z.to_int y)) - "Type Error: Unsigned right shift: expected integers, got " - | BitwiseAndL -> - binary_int_thing lit1 lit2 int64_bitwise_and - "Type Error: Bitwise 64bit conjunction: expected integers, got " - | BitwiseOrL -> - binary_int_thing lit1 lit2 int64_bitwise_or - "Type Error: Bitwise 64bit disjunction: expected integers, got " - | BitwiseXorL -> - binary_int_thing lit1 lit2 int64_bitwise_xor - "Type Error: Bitwise 64bit exclusive disjunction: expected \ - numbers, got " - | LeftShiftL -> - binary_int_thing lit1 lit2 int64_left_shift - "Type Error: 64bit Left shift: expected integers, got " + binary_int_thing lit1 lit2 (fun x y -> Z.shift_right x (Z.to_int y)) + | BitwiseAndL -> binary_int_thing lit1 lit2 int64_bitwise_and + | BitwiseOrL -> binary_int_thing lit1 lit2 int64_bitwise_or + | BitwiseXorL -> binary_int_thing lit1 lit2 int64_bitwise_xor + | LeftShiftL -> binary_int_thing lit1 lit2 int64_left_shift | SignedRightShiftL -> - binary_int_thing lit1 lit2 - (fun x y -> Z.shift_right x (Z.to_int y)) - "Type Error: 64bit Signed right shift: expected numbers, got " + binary_int_thing lit1 lit2 (fun x y -> Z.shift_right x (Z.to_int y)) | UnsignedRightShiftL -> - binary_int_thing lit1 lit2 - (fun x y -> Z.shift_right x (Z.to_int y)) - "Type Error: 64bit Unsigned right shift: expected integers, got " - | BitwiseAndF -> - binary_num_thing lit1 lit2 int32_bitwise_and - "Type Error: Bitwise float conjunction: expected floats, got " - | BitwiseOrF -> - binary_num_thing lit1 lit2 int32_bitwise_or - "Type Error: Bitwise float disjunction: expected floats, got " - | BitwiseXorF -> - binary_num_thing lit1 lit2 int32_bitwise_xor - "Type Error: Bitwise float exclusive disjunction: expected floats, \ - got " - | LeftShiftF -> - binary_num_thing lit1 lit2 int32_left_shift - "Type Error: Float Left shift: expected floats, got " - | SignedRightShiftF -> - binary_num_thing lit1 lit2 int32_right_shift - "Type Error: Float Signed right shift: expected floats, got " - | UnsignedRightShiftF -> - binary_num_thing lit1 lit2 uint32_right_shift_f - "Type Error: Float Unsigned right shift: expected floats, got " - | M_atan2 -> - binary_num_thing lit1 lit2 atan2 - "Type Error: Arc tangent: expected numbers, got " - | M_pow -> - binary_num_thing lit1 lit2 - (fun x y -> x ** y) - "Type Error: Exponentiation: expected numbers, got " - | StrCat -> ( - match (lit1, lit2) with - | String s1, String s2 -> String (s1 ^ s2) - | _, _ -> - raise - (Failure - (Fmt.str - "Type Error: List concatenation: expected lists, got %a \ - and %a" - CVal.M.pp lit1 CVal.M.pp lit2)))) + binary_int_thing lit1 lit2 (fun x y -> Z.shift_right x (Z.to_int y)) + | BitwiseAndF -> binary_num_thing lit1 lit2 int32_bitwise_and + | BitwiseOrF -> binary_num_thing lit1 lit2 int32_bitwise_or + | BitwiseXorF -> binary_num_thing lit1 lit2 int32_bitwise_xor + | LeftShiftF -> binary_num_thing lit1 lit2 int32_left_shift + | SignedRightShiftF -> binary_num_thing lit1 lit2 int32_right_shift + | UnsignedRightShiftF -> binary_num_thing lit1 lit2 uint32_right_shift_f + | M_atan2 -> binary_num_thing lit1 lit2 atan2 + | M_pow -> binary_num_thing lit1 lit2 ( ** ) + | StrCat -> + let s1 = as_str lit1 in + let s2 = as_str lit2 in + String (s1 ^ s2)) and evaluate_nop (nop : NOp.t) (ll : Literal.t list) : CVal.M.t = match nop with - | LstCat -> - LList - (List.fold_left - (fun ac (l : Literal.t) -> - match l with - | LList l -> List.append ac l - | _ -> - raise (Failure "List concat: supplied expression not a list.")) - [] ll) - | _ -> raise (Exceptions.Unsupported "Concrete evaluate_nop: set operators") + | LstCat -> LList (List.concat_map as_list ll) + | SetInter | SetUnion -> + raise (Exceptions.Unsupported "Concrete evaluate_nop: set operators") and evaluate_elist store (ll : Expr.t list) : CVal.M.t = match ll with | [] -> LList [] - | e :: ll -> ( + | e :: ll -> let ve = evaluate_expr store e in let vll = evaluate_expr store (EList ll) in - match vll with - | LList vll -> LList (ve :: vll) - | _ -> - raise - (Exceptions.Impossible - "eval_expr concrete: list reduces to non-list")) + let vll = as_list vll in + LList (ve :: vll) and evaluate_lstsub (store : CStore.t) (e1 : Expr.t) (e2 : Expr.t) (e3 : Expr.t) : CVal.M.t = @@ -524,23 +286,20 @@ and evaluate_lstsub (store : CStore.t) (e1 : Expr.t) (e2 : Expr.t) (e3 : Expr.t) let ve1 = ee e1 in let ve2 = ee e2 in let ve3 = ee e3 in - match (ve1, ve2, ve3) with - | LList les, Int start, Int len -> - let sub_list = - List_utils.list_sub les (Z.to_int start) (Z.to_int len) |> Option.get - in - LList sub_list - | _ -> - raise (Exceptions.Impossible "eval_expr concrete: lstsub type mismatch") + let les = as_list ve1 in + let start = as_int ve2 in + let len = as_int ve3 in + let sub_list = + List_utils.list_sub les (Z.to_int start) (Z.to_int len) |> Option.get + in + LList sub_list and evaluate_expr (store : CStore.t) (e : Expr.t) : CVal.M.t = try let ee = evaluate_expr store in match e with - | Lit l -> ( - match l with - | Constant c -> Literal.evaluate_constant c - | x -> x) + | Lit (Constant c) -> Literal.evaluate_constant c + | Lit lit -> lit | PVar x -> ( match CStore.get store x with | None -> @@ -553,12 +312,14 @@ and evaluate_expr (store : CStore.t) (e : Expr.t) : CVal.M.t = | NOp (nop, le) -> evaluate_nop nop (List.map ee le) | EList ll -> evaluate_elist store ll | LstSub (e1, e2, e3) -> evaluate_lstsub store e1 e2 e3 - | ALoc _ | LVar _ | ESet _ | Exists _ | EForall _ -> + | ALoc _ | LVar _ | ESet _ | Exists _ | ForAll _ -> raise - (Exceptions.Impossible "eval_expr concrete: aloc, lvar, set or exists") + (Exceptions.Impossible + "eval_expr concrete: aloc, lvar, set, exists or for all") with - | TypeError msg -> raise (TypeError msg) - | EvaluationError msg -> raise (EvaluationError msg) + | TypeError msg -> raise (TypeError (msg ^ Fmt.str " in %a" Expr.pp e)) + | EvaluationError msg -> + raise (EvaluationError (msg ^ Fmt.str " in %a" Expr.pp e)) | Division_by_zero -> raise (EvaluationError "Division by zero") | e -> let msg = Printexc.to_string e in diff --git a/GillianCore/engine/concrete_semantics/CState.ml b/GillianCore/engine/concrete_semantics/CState.ml index 03a60e7b..b305d9d8 100644 --- a/GillianCore/engine/concrete_semantics/CState.ml +++ b/GillianCore/engine/concrete_semantics/CState.ml @@ -70,29 +70,15 @@ end = struct | Bool false -> [] | _ -> raise (Failure "assume. illegal argument to assume") - let assume_a - ?matching:_ - ?production:_ - ?time:_ - (state : t) - (ps : Formula.t list) : t option = - let les : Expr.t option list = List.map Formula.to_expr ps in - let bs : CVal.M.t option list = - List.map (Option.map (eval_expr state)) les - in - if - List.for_all - (function - | Some (Bool true) -> true - | _ -> false) - bs - then Some state - else None + let assume_a ?matching:_ ?production:_ ?time:_ (state : t) (ps : Expr.t list) + : t option = + let bs : CVal.M.t list = List.map (eval_expr state) ps in + if List.for_all (( = ) (Bool true)) bs then Some state else None let assume_t (state : t) (v : vt) (t : Type.t) : t option = if Literal.type_of v = t then Some state else None - let assert_a (state : t) (ps : Formula.t list) : bool = + let assert_a (state : t) (ps : Expr.t list) : bool = Option.fold ~some:(fun _ -> true) ~none:false (assume_a state ps) let sat_check (_ : t) (l : Literal.t) : bool = @@ -101,7 +87,7 @@ end = struct | _ -> raise (Failure "SAT Check: non-boolean argument") (* Implentation MISSING!!! *) - let sat_check_f (_ : t) (_ : Formula.t list) : st option = None + let sat_check_f (_ : t) (_ : Expr.t list) : st option = None let pp fmt state = let heap, store, _ = state in @@ -152,7 +138,7 @@ end = struct (_ : (string * (string * vt) list) option) = raise (Failure "ERROR: run_spec called for non-abstract execution") - let unfolding_vals (_ : t) (_ : Formula.t list) : vt list = + let unfolding_vals (_ : t) (_ : Expr.t list) : vt list = raise (Failure "ERROR: unfolding_vals called for non-abstract execution") let evaluate_slcmd (_ : 'a MP.prog) (_ : SLCmd.t) (_ : t) : @@ -183,7 +169,7 @@ end = struct let update_subst (_ : t) (_ : st) : unit = () - let mem_constraints (_ : t) : Formula.t list = + let mem_constraints (_ : t) : Expr.t list = raise (Failure "DEATH. mem_constraints") let get_recovery_tactic _ = @@ -207,7 +193,7 @@ end = struct "Concrete printer: non-memory and non-type error") let can_fix (_ : err_t) : bool = false - let get_failing_constraint (_ : err_t) : Formula.t = True + let get_failing_constraint (_ : err_t) : Expr.t = Lit (Bool true) let get_fixes (_ : err_t) : Asrt.t list = raise (Failure "Concrete: get_fixes not implemented in CState.Make") From 0aa7e7902effce1eac5952ba758f9a64ec37632f Mon Sep 17 00:00:00 2001 From: N1ark Date: Tue, 24 Dec 2024 14:37:10 +0100 Subject: [PATCH 29/54] Update BiAbduction --- GillianCore/engine/BiAbduction/BiState.ml | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/GillianCore/engine/BiAbduction/BiState.ml b/GillianCore/engine/BiAbduction/BiState.ml index ce3268f0..beb46afb 100644 --- a/GillianCore/engine/BiAbduction/BiState.ml +++ b/GillianCore/engine/BiAbduction/BiState.ml @@ -77,7 +77,7 @@ module Make (State : SState.S) = struct ?(production = false) ?time:_ (bi_state : t) - (fs : Formula.t list) : t option = + (fs : Expr.t list) : t option = let { state; _ } = bi_state in match State.assume_a ~matching ~production state fs with | Some state -> Some { bi_state with state } @@ -89,11 +89,11 @@ module Make (State : SState.S) = struct let sat_check ({ state; _ } : t) (v : Expr.t) : bool = State.sat_check state v - let sat_check_f ({ state; _ } : t) (fs : Formula.t list) : - SVal.SESubst.t option = + let sat_check_f ({ state; _ } : t) (fs : Expr.t list) : SVal.SESubst.t option + = State.sat_check_f state fs - let assert_a ({ state; _ } : t) (fs : Formula.t list) : bool = + let assert_a ({ state; _ } : t) (fs : Expr.t list) : bool = State.assert_a state fs let equals ({ state; _ } : t) (v1 : Expr.t) (v2 : Expr.t) : bool = @@ -167,7 +167,7 @@ module Make (State : SState.S) = struct let frame_on _ _ _ = raise (Failure "ERROR: framing called for bi-abductive execution") - let unfolding_vals ({ state; _ } : t) (fs : Formula.t list) : Expr.t list = + let unfolding_vals ({ state; _ } : t) (fs : Expr.t list) : Expr.t list = State.unfolding_vals state fs let substitution_in_place ?subst_all:_ (_ : SVal.SESubst.t) (_ : t) = @@ -461,7 +461,7 @@ module Make (State : SState.S) = struct (** new functions *) - let mem_constraints ({ state; _ } : t) : Formula.t list = + let mem_constraints ({ state; _ } : t) : Expr.t list = State.mem_constraints state let is_overlapping_asrt (a : string) : bool = State.is_overlapping_asrt a From 8403b02d461e72ad7f4b1b1df09829b02a6f5ca0 Mon Sep 17 00:00:00 2001 From: N1ark Date: Tue, 24 Dec 2024 15:27:21 +0100 Subject: [PATCH 30/54] Update Abstraction --- .../engine/Abstraction/LogicPreprocessing.ml | 4 +- GillianCore/engine/Abstraction/MP.ml | 53 +++--- GillianCore/engine/Abstraction/Matcher.ml | 76 ++++---- GillianCore/engine/Abstraction/Normaliser.ml | 175 ++++++------------ GillianCore/engine/Abstraction/PState.ml | 26 +-- 5 files changed, 133 insertions(+), 201 deletions(-) diff --git a/GillianCore/engine/Abstraction/LogicPreprocessing.ml b/GillianCore/engine/Abstraction/LogicPreprocessing.ml index 3f3c1a7a..b325417b 100644 --- a/GillianCore/engine/Abstraction/LogicPreprocessing.ml +++ b/GillianCore/engine/Abstraction/LogicPreprocessing.ml @@ -361,9 +361,7 @@ let remove_equalities_between_binders_and_lvars binders assertion = let uf_maker = object inherit [_] Visitors.iter - method! visit_Not _ _ = () - method! visit_Or _ _ _ = () - method! visit_Eq _ e1 e2 = union_expr e1 e2 + method! visit_BinOp _ e1 op e2 = if op = Equal then union_expr e1 e2 end in uf_maker#visit_assertion () assertion; diff --git a/GillianCore/engine/Abstraction/MP.ml b/GillianCore/engine/Abstraction/MP.ml index 06248211..ce7e07c7 100644 --- a/GillianCore/engine/Abstraction/MP.ml +++ b/GillianCore/engine/Abstraction/MP.ml @@ -148,7 +148,7 @@ let rec missing_expr (kb : KB.t) (e : Expr.t) : KB.t list = Fmt.(brackets (list ~sep:semi kb_pp)) result); result - | Exists (bt, e) | EForall (bt, e) -> + | Exists (bt, e) | ForAll (bt, e) -> let kb' = KB.add_seq (List.to_seq bt |> Seq.map (fun (x, _) -> Expr.LVar x)) kb in @@ -286,7 +286,7 @@ let rec learn_expr (* TODO: Finish the remaining invertible binary operators *) | BinOp _ -> [] (* Can we learn anything from Exists? *) - | Exists _ | EForall _ -> [] + | Exists _ | ForAll _ -> [] and learn_expr_list (kb : KB.t) (le : (Expr.t * Expr.t) list) = (* L.(verbose (fun m -> m "Entering learn_expr_list: \nKB: %a\nList: %a" kb_pp kb Fmt.(brackets (list ~sep:semi (parens (pair ~sep:comma Expr.pp Expr.pp)))) le)); *) @@ -325,7 +325,7 @@ let simple_ins_expr_collector = (KB.empty, KB.singleton e) | UnOp (LstLen, ((PVar s | LVar s) as v)) when not (SS.mem s exclude) -> (KB.singleton v, KB.empty) - | Exists (bt, e) | EForall (bt, e) -> + | Exists (bt, e) | ForAll (bt, e) -> let exclude = List.fold_left (fun acc (x, _) -> SS.add x acc) exclude bt in @@ -401,28 +401,21 @@ let ins_and_outs_from_lists (kb : KB.t) (lei : Expr.t list) (leo : Expr.t list) (** [simple_ins_formula pf] returns the list of possible ins for a given formula [pf] *) -let rec simple_ins_formula (kb : KB.t) (pf : Formula.t) : KB.t list = +let rec simple_ins_formula (kb : KB.t) (pf : Expr.t) : KB.t list = let f = simple_ins_formula kb in match pf with - | True | False -> [] - | Not pf -> f pf + | UnOp (Not, pf) -> f pf (* Conjunction and disjunction are treated the same *) - | And (pf1, pf2) | Or (pf1, pf2) -> + | BinOp (pf1, And, pf2) | BinOp (pf1, Or, pf2) -> let ins_pf1 = f pf1 in let ins_pf2 = f pf2 in let ins = List_utils.cross_product ins_pf1 ins_pf2 KB.union in let ins = List_utils.remove_duplicates ins in List.map minimise_matchables ins - | Impl (f1, f2) -> simple_ins_formula kb (Or (Not f1, f2)) + | BinOp (f1, Impl, f2) -> + simple_ins_formula kb (BinOp (UnOp (Not, f1), Or, f2)) (* Relational formulae are all treated the same *) - | Eq (e1, e2) - | ILess (e1, e2) - | ILessEq (e1, e2) - | FLess (e1, e2) - | FLessEq (e1, e2) - | StrLess (e1, e2) - | SetMem (e1, e2) - | SetSub (e1, e2) -> + | BinOp (e1, _, e2) -> let ins_e1 = simple_ins_expr e1 in let ins_e2 = simple_ins_expr e2 in let ins = List_utils.list_product [ ins_e1; ins_e2 ] in @@ -434,8 +427,11 @@ let rec simple_ins_formula (kb : KB.t) (pf : Formula.t) : KB.t list = in let ins = List_utils.remove_duplicates ins in List.map minimise_matchables ins - (* Forall must exclude the binders *) - | ForAll (binders, pf) -> + | UnOp (_, e) -> + e |> simple_ins_expr |> List_utils.remove_duplicates + |> List.map minimise_matchables + (* ForAll/Exists must exclude the binders *) + | Exists (binders, pf) | ForAll (binders, pf) -> let binders = List.fold_left (fun acc (b, _) -> KB.add (Expr.LVar b) acc) @@ -444,20 +440,18 @@ let rec simple_ins_formula (kb : KB.t) (pf : Formula.t) : KB.t list = let ins_pf = f pf in let ins = List.map (fun ins -> KB.diff ins binders) ins_pf in List.map minimise_matchables ins - | IsInt e -> - e |> simple_ins_expr |> List_utils.remove_duplicates - |> List.map minimise_matchables + | Lit _ | PVar _ | LVar _ | ALoc _ | LstSub _ | NOp _ | EList _ | ESet _ -> [] (** [ins_outs_formula kb pf] returns a list of possible ins-outs pairs for a given formula [pf] under a given knowledge base [kb] *) -let ins_outs_formula (kb : KB.t) (pf : Formula.t) : (KB.t * outs) list = +let ins_outs_formula (kb : KB.t) (pf : Expr.t) : (KB.t * outs) list = let default_ins = simple_ins_formula kb pf in let default_result : (KB.t * outs) list = List.map (fun ins -> (ins, [])) default_ins in match pf with - | Eq (e1, e2) -> ( - L.verbose (fun fmt -> fmt "IO Equality: %a" Formula.pp pf); + | BinOp (e1, Equal, e2) -> ( + L.verbose (fun fmt -> fmt "IO Equality: %a" Expr.pp pf); L.verbose (fun fmt -> fmt "Ins: %a" Fmt.(brackets (list ~sep:semi kb_pp)) default_ins); L.verbose (fun fmt -> fmt "KB: %a" kb_pp kb); @@ -487,11 +481,11 @@ let ins_outs_formula (kb : KB.t) (pf : Formula.t) : (KB.t * outs) list = (list ~sep:semi (parens (pair ~sep:comma kb_pp outs_pp)))) result); result) - | And _ -> + | BinOp (_, And, _) -> raise (Failure (Format.asprintf "ins_outs_formula: Should have been reduced: %a" - Formula.pp pf)) + Expr.pp pf)) | _ -> default_result (** [ins_outs_assertion kb a] returns a list of possible ins-outs pairs @@ -538,8 +532,8 @@ let ins_outs_assertion let simplify_asrts ?(sorted = true) a = let rec aux (a : Asrt.atom) : Asrt.atom list = match a with - | Pure True | Emp -> [] - | Pure (And (f1, f2)) -> aux (Pure f1) @ aux (Pure f2) + | Pure (Lit (Bool true)) | Emp -> [] + | Pure (BinOp (f1, And, f2)) -> aux (Pure f1) @ aux (Pure f2) | Pure _ | Pred _ | CorePred _ | Wand _ -> [ a ] | Types _ -> ( let a = Reduction.reduce_assertion [ a ] in @@ -548,7 +542,8 @@ let simplify_asrts ?(sorted = true) a = | _ -> List.concat_map aux a) in let atoms = List.concat_map aux a in - if List.mem (Asrt.Pure False) atoms then [ Asrt.Pure False ] + if List.mem (Asrt.Pure (Lit (Bool false))) atoms then + [ Asrt.Pure (Lit (Bool false)) ] else if not sorted then atoms else let overlapping, separating = List.partition Asrt.is_pure_asrt atoms in diff --git a/GillianCore/engine/Abstraction/Matcher.ml b/GillianCore/engine/Abstraction/Matcher.ml index c801fbe3..42995e28 100644 --- a/GillianCore/engine/Abstraction/Matcher.ml +++ b/GillianCore/engine/Abstraction/Matcher.ml @@ -307,9 +307,9 @@ module Make (State : SState.S) : preds_list; { state; preds; wands = Wands.init []; pred_defs; variants } - type cons_pure_result = Success of state_t | Abort of Formula.t | Vanish + type cons_pure_result = Success of state_t | Abort of Expr.t | Vanish - let cons_pure (state : state_t) (f : Formula.t) : cons_pure_result = + let cons_pure (state : state_t) (f : Expr.t) : cons_pure_result = if !Config.under_approximation then match State.assume_a ~matching:true state [ f ] with | Some state -> Success state @@ -603,12 +603,12 @@ module Make (State : SState.S) : List.fold_left2 (fun facts param le -> let subst = - Formula.subst_expr_for_expr ~to_subst:param ~subst_with:le + Expr.subst_expr_for_expr ~to_subst:param ~subst_with:le in List.map subst facts) facts params les in - let facts = Asrt.Pure (Formula.conjunct facts) in + let facts = Asrt.Pure (Expr.conjunct facts) in produce_assertion { state; preds; wands; pred_defs; variants } subst facts @@ -628,7 +628,7 @@ module Make (State : SState.S) : let rargs = List.map (subst_in_expr subst) rargs in Wands.extend wands Wands.{ lhs = (lname, largs); rhs = (rname, rargs) }; Res_list.return astate - | Pure (Eq (PVar x, le)) | Pure (Eq (le, PVar x)) -> ( + | Pure (BinOp (PVar x, Equal, le)) | Pure (BinOp (le, Equal, PVar x)) -> ( L.verbose (fun fmt -> fmt "Pure assertion."); match SVal.SESubst.get subst (PVar x) with | Some v_x -> @@ -639,7 +639,7 @@ module Make (State : SState.S) : [ Ok { state; preds; wands; pred_defs; variants } ]) (State.assume_a ~matching:true ~production:!Config.delay_entailment state - [ Eq (v_x, v_le) ]) + [ BinOp (v_x, Equal, v_le) ]) in Option.value ~default: @@ -657,7 +657,7 @@ module Make (State : SState.S) : Res_list.return (update_store astate x v)) | Pure f -> ( L.verbose (fun fmt -> fmt "Pure assertion."); - let f' = SVal.SESubst.substitute_formula subst ~partial:false f in + let f' = SVal.SESubst.subst_in_expr subst ~partial:false f in (* let pp_state = match !Config.pbn with | false -> State.pp @@ -676,7 +676,7 @@ module Make (State : SState.S) : | None -> let msg = Fmt.str "Produce Simple Assertion: Cannot assume pure formula %a." - Formula.pp f' + Expr.pp f' in other_state_err msg | Some state' -> @@ -699,7 +699,7 @@ module Make (State : SState.S) : with e -> let admissible = State.assume_a ~time:"Produce: final check" ~matching:true - intermediate_state.state [ True ] + intermediate_state.state [ Expr.true_ ] in if !Config.delay_entailment && Option.is_none admissible then ( L.verbose (fun fmt -> @@ -716,7 +716,7 @@ module Make (State : SState.S) : L.verbose (fun fmt -> fmt "Produce: final check"); try State.assume_a ~time:"Produce: final check" ~matching:true state - [ True ] + [ Expr.true_ ] with _ -> None in L.verbose (fun fmt -> fmt "Concluded final check"); @@ -789,7 +789,7 @@ module Make (State : SState.S) : m "@[Using unfold info, obtained subst:@\n%a@]@\n" SVal.SESubst.pp subst) - let resource_fail = Res_list.error_with (StateErr.EAsrt ([], True, [])) + let resource_fail = Res_list.error_with (StateErr.EAsrt ([], Expr.true_, [])) (* WARNING: At the moment, unfold behaves over-approximately, it will return only success of only error. We only use unfold and fold in OX mode right now, and we don't quite know the meaning of UX fold/unfold. *) @@ -991,14 +991,14 @@ module Make (State : SState.S) : | Success new_state -> Res_list.return { astate with state = new_state } | Abort fail_pf -> let error = - StateErr.EAsrt ([], Not fail_pf, [ [ Pure fail_pf ] ]) + StateErr.EAsrt ([], UnOp (Not, fail_pf), [ [ Pure fail_pf ] ]) in Res_list.error_with error | Vanish -> Res_list.vanish) | None -> L.verbose (fun m -> m "Could not find any match for the required wand!!!"); - Res_list.error_with (StateErr.EPure False) + Res_list.error_with (StateErr.EPure Expr.false_) (** Consumes a predicate from the state. If the predicate is not "verbatim" in our set of preds, @@ -1050,7 +1050,7 @@ module Make (State : SState.S) : ({ state = new_state; wands; preds; pred_defs; variants }, vs) | Abort fail_pf -> let error = - StateErr.EAsrt ([], Not fail_pf, [ [ Pure fail_pf ] ]) + StateErr.EAsrt ([], UnOp (Not, fail_pf), [ [ Pure fail_pf ] ]) in Res_list.error_with error | Vanish -> Res_list.vanish)) @@ -1080,7 +1080,7 @@ module Make (State : SState.S) : | _ -> let values = List.filter_map Fun.id vs in (* The `False` as second parameter is required for the fixing mechanism to trigger *) - Res_list.error_with (StateErr.EAsrt (values, False, [])) + Res_list.error_with (StateErr.EAsrt (values, Expr.false_, [])) and match_ins_outs_lists (state : State.t) @@ -1118,7 +1118,7 @@ module Make (State : SState.S) : with _ -> None in match outs with - | None -> Abort True + | None -> Abort Expr.true_ | Some outs -> ( L.verbose (fun fmt -> fmt "Substed outs: %a" @@ -1147,7 +1147,7 @@ module Make (State : SState.S) : match ac with | Abort _ | Vanish -> ac | Success state -> - let pf : Formula.t = Eq (vd, od) in + let pf = Expr.BinOp (vd, Equal, od) in cons_pure state pf) (Success state) vos eos with Invalid_argument _ -> @@ -1247,7 +1247,8 @@ module Make (State : SState.S) : { state = state'''; preds; wands; pred_defs; variants } | Abort fail_pf -> let error = - StateErr.EAsrt ([], Not fail_pf, [ [ Pure fail_pf ] ]) + StateErr.EAsrt + ([], UnOp (Not, fail_pf), [ [ Pure fail_pf ] ]) in Res_list.error_with error | Vanish -> Res_list.vanish) @@ -1300,7 +1301,7 @@ module Make (State : SState.S) : let fold_outs_info = (subst, step, les_outs) in consume_wand ~fold_outs_info astate subst { lhs; rhs } (* Conjunction should not be here *) - | Pure (Formula.And _) -> + | Pure (BinOp (_, And, _)) -> raise (Failure "Match assertion: And: should have been reduced") (* Other pure assertions *) | Pure f -> ( @@ -1321,7 +1322,7 @@ module Make (State : SState.S) : Ok discharges | Some out' when Expr.equal out out' -> Ok discharges | Some out' -> - let new_discharge = Formula.Eq (out, out') in + let new_discharge = Expr.BinOp (out, Equal, out') in Ok (new_discharge :: discharges)) (Ok []) outs in @@ -1331,23 +1332,23 @@ module Make (State : SState.S) : Fmt.failwith "INTERNAL ERROR: Matching failure: do not know all ins \ for %a" - Formula.pp f + Expr.pp f | Ok discharges -> discharges in (* To match a pure formula we must know all ins *) - let opf = SVal.SESubst.substitute_in_formula_opt subst f in + let opf = SVal.SESubst.subst_in_expr_opt subst f in match opf with | None -> Fmt.failwith "Matching failure: do not know all ins for %a" - Formula.pp f + Expr.pp f | Some pf -> ( let discharges_pf = - List.fold_left Formula.Infix.( #&& ) True discharges + List.fold_left Expr.Infix.( && ) Expr.true_ discharges in let discharges_pf = Reduction.reduce_formula ~matching:true discharges_pf in - let to_asrt = Formula.Infix.( #&& ) pf discharges_pf in + let to_asrt = Expr.Infix.( && ) pf discharges_pf in match cons_pure state to_asrt with | Success new_state -> Res_list.return @@ -1356,13 +1357,13 @@ module Make (State : SState.S) : | Abort _ -> let vs = State.unfolding_vals state [ pf ] in let error = - StateErr.EAsrt (vs, Not pf, [ [ Pure pf ] ]) + StateErr.EAsrt (vs, Expr.UnOp (Not, pf), [ [ Pure pf ] ]) in Res_list.error_with error)) | Types les -> ( let corrections = List.fold_left - (fun (ac : Formula.t list) (le, t) -> + (fun (ac : Expr.t list) (le, t) -> let v_le = (subst_in_expr_opt astate subst) le in let v_le : Expr.t = match v_le with @@ -1371,8 +1372,9 @@ module Make (State : SState.S) : in match State.get_type state v_le with | Some t' -> - if not (Type.equal t t') then False :: ac else ac - | None -> Eq (UnOp (TypeOf, v_le), Lit (Type t)) :: ac) + if not (Type.equal t t') then Expr.false_ :: ac else ac + | None -> + BinOp (UnOp (TypeOf, v_le), Equal, Lit (Type t)) :: ac) [] les in @@ -1391,9 +1393,10 @@ module Make (State : SState.S) : let les = List.filter_map (subst_in_expr_opt astate subst) les in - let conjunct = Formula.conjunct corrections in + let conjunct = Expr.conjunct corrections in let error = - StateErr.EAsrt (les, Not conjunct, [ [ Pure conjunct ] ]) + StateErr.EAsrt + (les, UnOp (Not, conjunct), [ [ Pure conjunct ] ]) in Res_list.error_with error) (* LTrue, LFalse, LEmp, LStar *) @@ -1429,7 +1432,8 @@ module Make (State : SState.S) : | Pure pf -> let { state = bstate; _ } = state in let vs = State.unfolding_vals bstate [ pf ] in - Res_list.error_with (StateErr.EAsrt (vs, Not pf, [ [ Pure pf ] ])) + Res_list.error_with + (StateErr.EAsrt (vs, UnOp (Not, pf), [ [ Pure pf ] ])) | asrt -> let other_error = StateErr.EOther @@ -1975,9 +1979,9 @@ module Make (State : SState.S) : let learning_equalities = List.map2 (fun old_out new_out -> - let open Formula.Infix in Asrt.Pure - (Expr.PVar old_out) #== (subst_in_expr pvar_subst new_out)) + (Expr.Infix.( == ) (Expr.PVar old_out) + (subst_in_expr pvar_subst new_out))) out_params new_outs_learn in let atoms = List.rev_append new_cps learning_equalities in @@ -2030,7 +2034,7 @@ module Make (State : SState.S) : (fun acc vd od -> let open Syntaxes.Result in let* acc = acc in - let equality = Formula.Eq (vd, od) in + let equality = Expr.BinOp (vd, Equal, od) in if State.assert_a state.lhs_state.state [ equality ] || State.assert_a state.current_state.state [ equality ] @@ -2039,7 +2043,7 @@ module Make (State : SState.S) : Error [ StateErr.EAsrt - ([], Formula.Infix.fnot equality, [ [ Pure equality ] ]); + ([], Expr.Infix.not equality, [ [ Pure equality ] ]); ]) (Ok state) obtained expected diff --git a/GillianCore/engine/Abstraction/Normaliser.ml b/GillianCore/engine/Abstraction/Normaliser.ml index 78d8d890..275b3934 100644 --- a/GillianCore/engine/Abstraction/Normaliser.ml +++ b/GillianCore/engine/Abstraction/Normaliser.ml @@ -21,10 +21,11 @@ module Make (SPState : PState.S) = struct let find_list_exprs_to_concretize (a : Asrt.t) : (Expr.t, Expr.t list) Hashtbl.t = let collect_concretizable_lists = function - | Asrt.Pure (Eq (EList _, EList _)) -> [] - | Pure (Eq (le, EList les)) | Pure (Eq (EList les, le)) -> [ (le, les) ] - | Pure (Eq (UnOp (LstLen, le), Lit (Int i))) - | Pure (Eq (Lit (Int i), UnOp (LstLen, le))) -> + | Asrt.Pure (BinOp (EList _, Equal, EList _)) -> [] + | Pure (BinOp (le, Equal, EList les)) + | Pure (BinOp (EList les, Equal, le)) -> [ (le, les) ] + | Pure (BinOp (UnOp (LstLen, le), Equal, Lit (Int i))) + | Pure (BinOp (Lit (Int i), Equal, UnOp (LstLen, le))) -> let les = List.init (Z.to_int i) (fun _ -> Expr.LVar (LVar.alloc ())) in @@ -74,7 +75,7 @@ module Make (SPState : PState.S) = struct (a : Asrt.t) (new_lists : (Expr.t, Expr.t list) Hashtbl.t) : Asrt.t = Hashtbl.fold - (fun le les (ac : Asrt.t) -> Pure (Eq (le, EList les)) :: ac) + (fun le les (ac : Asrt.t) -> Pure (BinOp (le, Equal, EList les)) :: ac) new_lists a in @@ -141,11 +142,10 @@ module Make (SPState : PState.S) = struct raise (Failure "Non-integer string index") | _, _ -> BinOp (nle1, StrNth, nle2)) | _ -> ( - match ((nle1 : Expr.t), (nle2 : Expr.t)) with - | Lit lit1, Lit lit2 -> + match (nle1, nle2) with + | Lit _, Lit _ -> let lit = - CExprEval.evaluate_binop (CStore.init []) bop (Lit lit1) - (Lit lit2) + CExprEval.evaluate_binop (CStore.init []) bop nle1 nle2 in Lit lit | _, _ -> BinOp (nle1, bop, nle2))) @@ -174,7 +174,7 @@ module Make (SPState : PState.S) = struct "normalise_lexpr: program variable in normalised \ expression") | BinOp (_, _, _) | UnOp (_, _) -> UnOp (TypeOf, nle1) - | Exists _ | EForall _ -> Lit (Type BooleanType) + | Exists _ | ForAll _ -> Lit (Type BooleanType) | EList _ | LstSub _ | NOp (LstCat, _) -> Lit (Type ListType) | NOp (_, _) | ESet _ -> Lit (Type SetType)) | _ -> UnOp (uop, nle1))) @@ -210,21 +210,7 @@ module Make (SPState : PState.S) = struct | _, Lit (Num _), Lit (Num _) -> raise (Failure "Sublist indexes non-integer") | _, _, _ -> LstSub (nle1, nle2, nle3)) - | Exists (bt, e) -> ( - let new_gamma = Type_env.copy gamma in - List.iter - (fun (x, t) -> - match t with - | Some t -> Type_env.update new_gamma x t - | None -> Type_env.remove new_gamma x) - bt; - let ne = normalise_lexpr ~no_types ~store ~subst new_gamma e in - let lvars = Expr.lvars ne in - let bt = List.filter (fun (x, _) -> SS.mem x lvars) bt in - match bt with - | [] -> ne - | _ -> Exists (bt, ne)) - | EForall (bt, e) -> ( + | ForAll (bt, e) | Exists (bt, e) -> ( let new_gamma = Type_env.copy gamma in List.iter (fun (x, t) -> @@ -235,9 +221,11 @@ module Make (SPState : PState.S) = struct let ne = normalise_lexpr ~no_types ~store ~subst new_gamma e in let lvars = Expr.lvars ne in let bt = List.filter (fun (x, _) -> SS.mem x lvars) bt in - match bt with - | [] -> ne - | _ -> EForall (bt, ne)) + match (bt, le) with + | [], _ -> ne + | _, Exists _ -> Exists (bt, ne) + | _, ForAll _ -> ForAll (bt, ne) + | _, _ -> failwith "Impossible") in if not no_types then Typing.infer_types_expr gamma result; @@ -245,12 +233,14 @@ module Make (SPState : PState.S) = struct let extend_typing_env_using_assertion_info (gamma : Type_env.t) - (a_list : Formula.t list) : unit = + (a_list : Expr.t list) : unit = List.iter (fun a -> - match (a : Formula.t) with - | Eq (LVar x, le) | Eq (le, LVar x) | Eq (PVar x, le) | Eq (le, PVar x) - -> ( + match (a : Expr.t) with + | BinOp (LVar x, Equal, le) + | BinOp (le, Equal, LVar x) + | BinOp (PVar x, Equal, le) + | BinOp (le, Equal, PVar x) -> ( let x_type = Type_env.get gamma x in match x_type with | None -> @@ -267,71 +257,12 @@ module Make (SPState : PState.S) = struct ----------------------------------------------------- _____________________________________________________ *) - let normalise_logic_expression - ?(no_types = false) - (store : SStore.t) - (gamma : Type_env.t) - (subst : SESubst.t) - (le : Expr.t) : Expr.t = - let le' = normalise_lexpr ~no_types ~store ~subst gamma le in - le' - - (* ----------------------------------------------------- - Normalise Pure Assertion (only one!) - ----------------------------------------------------- - Invoke normalise_logic_expression on all the logic - expressions of a - _____________________________________________________ - *) - let rec normalise_pure_assertion - ?(no_types = false) - (store : SStore.t) - (gamma : Type_env.t) - (subst : SESubst.t) - (assertion : Formula.t) : Formula.t = - let fa = normalise_pure_assertion ~no_types store gamma subst in - let fant = normalise_pure_assertion ~no_types:true store gamma subst in - let fe = normalise_logic_expression ~no_types store gamma subst in - let result : Formula.t = - match (assertion : Formula.t) with - | Eq (le1, le2) -> Eq (fe le1, fe le2) - | ILess (le1, le2) -> ILess (fe le1, fe le2) - | ILessEq (le1, le2) -> ILessEq (fe le1, fe le2) - | FLess (le1, le2) -> FLess (fe le1, fe le2) - | FLessEq (le1, le2) -> FLessEq (fe le1, fe le2) - | Not (Eq (le1, le2)) -> Not (Eq (fe le1, fe le2)) - | Not (FLessEq (le1, le2)) -> Not (FLessEq (fe le1, fe le2)) - | Not (FLess (le1, le2)) -> Not (FLess (fe le1, fe le2)) - | Not (ILessEq (le1, le2)) -> Not (ILessEq (fe le1, fe le2)) - | Not (ILess (le1, le2)) -> Not (ILess (fe le1, fe le2)) - | Not (SetSub (le1, le2)) -> Not (SetSub (fe le1, fe le2)) - | Not (SetMem (le1, le2)) -> Not (SetMem (fe le1, fe le2)) - | And (a1, a2) -> And (fa a1, fa a2) - | Or (a1, a2) -> Or (fa a1, fa a2) - | False -> False - | True -> True - | SetSub (le1, le2) -> SetSub (fe le1, fe le2) - | SetMem (le1, le2) -> SetMem (fe le1, fe le2) - | ForAll (bt, a) -> ForAll (bt, fant a) - | IsInt e -> IsInt (fe e) - | Impl (a, b) -> Impl (fa a, fa b) - | _ -> - let msg = - Fmt.str - "normalise_pure_assertion can only process pure assertions: %a" - Formula.pp assertion - in - raise (Failure msg) - in - if not no_types then Typing.infer_types_formula gamma result; - result - let normalise_pure_assertions (store : SStore.t) (gamma : Type_env.t) (subst : SESubst.t) (args : SS.t option) - (fs : Formula.t list) : PFS.t = + (fs : Expr.t list) : PFS.t = let pvar_equalities = Hashtbl.create 1 in let non_store_pure_assertions = Stack.create () in @@ -342,16 +273,19 @@ module Make (SPState : PState.S) = struct * or E = x, for a logical expression E and a variable x * ----------------------------------------------------------------------------------- *) - let init_pvar_equalities (fs : Formula.t list) : unit = + let init_pvar_equalities (fs : Expr.t list) : unit = List.iter - (fun (f : Formula.t) : unit -> + (fun (f : Expr.t) : unit -> match f with - | Eq (PVar x, e) | Eq (e, PVar x) -> + | BinOp (PVar x, Equal, e) | BinOp (e, Equal, PVar x) -> if (not (Hashtbl.mem pvar_equalities x)) && not (SStore.mem store x) then Hashtbl.add pvar_equalities x e - else Stack.push (Formula.Eq (PVar x, e)) non_store_pure_assertions + else + Stack.push + (Expr.BinOp (PVar x, Equal, e)) + non_store_pure_assertions | _ -> Stack.push f non_store_pure_assertions) fs in @@ -426,7 +360,7 @@ module Make (SPState : PState.S) = struct try let e = Hashtbl.find pvar_equalities var in Stack.push - (Formula.Eq (LVar (new_lvar_name var), e)) + (Expr.BinOp (LVar (new_lvar_name var), Equal, e)) non_store_pure_assertions; Hashtbl.remove pvar_equalities var with _ -> @@ -484,8 +418,7 @@ module Make (SPState : PState.S) = struct *) let fill_store args = let def_pvars = - SS.of_list - (List.concat (List.map (fun f -> SS.elements (Formula.pvars f)) fs)) + fs |> List.map Expr.pvars |> List.fold_left SS.union SS.empty in let p_vars = Option.value ~default:def_pvars args in SS.iter @@ -509,9 +442,7 @@ module Make (SPState : PState.S) = struct while not (Stack.is_empty non_store_pure_assertions) do let p_assertion = Stack.pop non_store_pure_assertions in - let p_assertion' = - normalise_pure_assertion store gamma subst p_assertion - in + let p_assertion' = normalise_lexpr ~store ~subst gamma p_assertion in PFS.extend pfs p_assertion'; cur_index := !cur_index + 1 done; @@ -556,7 +487,7 @@ module Make (SPState : PState.S) = struct (** Separate an assertion into: core_asrts, pure, typing and predicates *) let separate_assertion (a : Asrt.t) : (string * Expr.t list * Expr.t list) list - * Formula.t list + * Expr.t list * (Expr.t * Type.t) list * (string * Expr.t list) list * Wands.wand list = @@ -587,7 +518,7 @@ module Make (SPState : PState.S) = struct m "%s : %s" ((Fmt.to_to_string Expr.pp) e) (Type.str t))) type_list; - let fe = normalise_logic_expression store gamma subst in + let fe = normalise_lexpr ~store ~subst gamma in let type_check_lexpr (le : Expr.t) (t : Type.t) : bool = let le_type, success = Typing.type_lexpr gamma le in @@ -639,7 +570,7 @@ module Make (SPState : PState.S) = struct (gamma : Type_env.t) (subst : SVal.SESubst.t) (pred_asrts : (string * Expr.t list) list) : Preds.t = - let fe = normalise_logic_expression store gamma subst in + let fe = normalise_lexpr ~store ~subst gamma in let preds = Preds.init [] in List.iter @@ -660,7 +591,7 @@ module Make (SPState : PState.S) = struct (fun facts (param, le) -> List.map (fun fact -> - Formula.subst_expr_for_expr ~to_subst:param ~subst_with:le + Expr.subst_expr_for_expr ~to_subst:param ~subst_with:le fact) facts) pred_def.pred.pred_facts (List.combine params les) @@ -672,7 +603,7 @@ module Make (SPState : PState.S) = struct preds let generate_overlapping_constraints - (c_asrts : (string * Expr.t list * Expr.t list) list) : Formula.t list = + (c_asrts : (string * Expr.t list * Expr.t list) list) : Expr.t list = let partition (c_asrts : (string * Expr.t list * Expr.t list) list) : (string, (Expr.t list * Expr.t list) list) Hashtbl.t = let summary : (string, (Expr.t list * Expr.t list) list) Hashtbl.t = @@ -693,24 +624,24 @@ module Make (SPState : PState.S) = struct let generate_constraint (ins_outs_pair : (Expr.t * Expr.t) list * (Expr.t * Expr.t) list) : - Formula.t = + Expr.t = let ins_pairs, outs_pairs = ins_outs_pair in let ins_fo = - Formula.disjunct + Expr.disjunct (List.map - (fun (i1, i2) -> Formula.Not (Formula.Eq (i1, i2))) + (fun (i1, i2) -> Expr.UnOp (Not, Expr.BinOp (i1, Equal, i2))) ins_pairs) in let outs_fo = - Formula.conjunct - (List.map (fun (o1, o2) -> Formula.Eq (o1, o2)) outs_pairs) + Expr.conjunct + (List.map (fun (o1, o2) -> Expr.BinOp (o1, Equal, o2)) outs_pairs) in - Or (ins_fo, outs_fo) + BinOp (ins_fo, Or, outs_fo) in let summary_to_constraints (summary : (string, (Expr.t list * Expr.t list) list) Hashtbl.t) : - Formula.t list = + Expr.t list = let f_aux (ins1, outs1) (ins2, outs2) = if List.length ins1 <> List.length ins2 @@ -721,7 +652,7 @@ module Make (SPState : PState.S) = struct Hashtbl.fold (fun (_ : _) (a_asrts : (Expr.t list * Expr.t list) list) - (_ : Formula.t list) : Formula.t list -> + (_ : Expr.t list) : Expr.t list -> let pre_constraints = List_utils.cross_product a_asrts a_asrts f_aux in @@ -749,7 +680,7 @@ module Make (SPState : PState.S) = struct (c_asrts : (string * Expr.t list * Expr.t list) list) : (string * Expr.t list * Expr.t list) list * SESubst.t * SESubst.t = let new_pfs = PFS.copy pfs in - let fe = normalise_logic_expression store gamma subst in + let fe = normalise_lexpr ~store ~subst gamma in let c_asrts' = List.map (fun (a, ins, outs) -> (a, List.map fe ins, List.map fe outs)) @@ -772,7 +703,7 @@ module Make (SPState : PState.S) = struct L.verbose (fun m -> m "pfs after overlapping constraints:\n%a\nSubst:\n%a\nSubst':\n%a\n" (* FIXME: Shouldn't use PFS.to_list but Fmt.iter and PFS.iter *) - (Fmt.list ~sep:(Fmt.any "@\n") Formula.pp) + (Fmt.list ~sep:(Fmt.any "@\n") Expr.pp) (PFS.to_list new_pfs) SESubst.pp subst SESubst.pp subst'); let f_subst = SESubst.subst_in_expr subst' ~partial:true in @@ -848,7 +779,7 @@ module Make (SPState : PState.S) = struct None)) [ astate ] - let subst_to_pfs ?(svars : SS.t option) (subst : SESubst.t) : Formula.t list = + let subst_to_pfs ?(svars : SS.t option) (subst : SESubst.t) : Expr.t list = let subst_lvs = SESubst.to_list subst in let subst_lvs' = match svars with @@ -867,7 +798,7 @@ module Make (SPState : PState.S) = struct | _ -> false) subst_lvs in - List.map (fun (e, le) -> Formula.Eq (e, le)) subst_lvs' + List.map (fun (e, le) -> Expr.BinOp (e, Equal, le)) subst_lvs' let normalise_a_bit (a : Asrt.t) = let a = Reduction.reduce_assertion a in @@ -875,10 +806,10 @@ module Make (SPState : PState.S) = struct let find_spec_var_eqs (a : Asrt.atom) = match a with - | Pure (Eq (LVar x, LVar y)) + | Pure (BinOp (LVar x, Equal, LVar y)) when is_spec_var_name x && not (is_spec_var_name y) -> SESubst.put subst (LVar y) (LVar x) - | Pure (Eq (LVar x, LVar y)) + | Pure (BinOp (LVar x, Equal, LVar y)) when is_spec_var_name y && not (is_spec_var_name x) -> SESubst.put subst (LVar x) (LVar y) | _ -> () @@ -892,7 +823,7 @@ module Make (SPState : PState.S) = struct ~(init_data : SPState.init_data) ?(pvars : SS.t option) (a : Asrt.t) : ((SPState.t * SESubst.t) list, string) result = - let falsePFs pfs = PFS.mem pfs False in + let falsePFs pfs = PFS.mem pfs Expr.false_ in let a = normalise_a_bit a in let svars = SS.filter is_spec_var_name (Asrt.lvars a) in L.verbose (fun m -> diff --git a/GillianCore/engine/Abstraction/PState.ml b/GillianCore/engine/Abstraction/PState.ml index ac0a1ce3..bb2a2923 100644 --- a/GillianCore/engine/Abstraction/PState.ml +++ b/GillianCore/engine/Abstraction/PState.ml @@ -189,7 +189,7 @@ module Make (State : SState.S) : ?(production = false) ?(time = "") (astate : t) - (fs : Formula.t list) : t option = + (fs : Expr.t list) : t option = match State.assume_a ~matching ~production ~time astate.state fs with | Some state -> Some { astate with state } | None -> None @@ -201,10 +201,10 @@ module Make (State : SState.S) : let sat_check (astate : t) (v : Expr.t) : bool = State.sat_check astate.state v - let sat_check_f (astate : t) (fs : Formula.t list) : SVal.SESubst.t option = + let sat_check_f (astate : t) (fs : Expr.t list) : SVal.SESubst.t option = State.sat_check_f astate.state fs - let assert_a (astate : t) (fs : Formula.t list) : bool = + let assert_a (astate : t) (fs : Expr.t list) : bool = State.assert_a astate.state fs let equals (astate : t) (v1 : Expr.t) (v2 : Expr.t) : bool = @@ -503,7 +503,9 @@ module Make (State : SState.S) : @ additional_bindings in let new_bindings = - List.map (fun (e, e_v) -> Asrt.Pure (Eq (e, e_v))) new_bindings + List.map + (fun (e, e_v) -> Asrt.Pure (BinOp (e, Equal, e_v))) + new_bindings in let full_subst = make_id_subst a in let a_produce = new_bindings in @@ -532,7 +534,7 @@ module Make (State : SState.S) : StateErr.EOther msg) result | Error err -> - let fail_pfs : Formula.t = State.get_failing_constraint err in + let fail_pfs : Expr.t = State.get_failing_constraint err in let failing_model = State.sat_check_f astate.state [ fail_pfs ] in let msg = @@ -666,7 +668,7 @@ module Make (State : SState.S) : match result with | Ok state -> Ok state | Error err -> - let fail_pfs : Formula.t = State.get_failing_constraint err in + let fail_pfs : Expr.t = State.get_failing_constraint err in let failing_model = State.sat_check_f astate.state [ fail_pfs ] in let () = L.print_to_all @@ -720,7 +722,7 @@ module Make (State : SState.S) : | Expr.PVar x when List.mem x pvar_binders -> false | UnOp (LstLen, _) -> false | _ -> true) - |> List.map (fun (e, e_v) -> Asrt.Pure (Eq (e, e_v))) + |> List.map (fun (e, e_v) -> Asrt.Pure (BinOp (e, Equal, e_v))) in let subst_bindings = make_id_subst bindings in let pvar_subst_list_known = @@ -1007,7 +1009,9 @@ module Make (State : SState.S) : @ additional_bindings in let new_bindings = - List.map (fun (e, e_v) -> Asrt.Pure (Eq (e, e_v))) new_bindings + List.map + (fun (e, e_v) -> Asrt.Pure (BinOp (e, Equal, e_v))) + new_bindings in let a_new_bindings = new_bindings in let subst_bindings = make_id_subst a_new_bindings in @@ -1044,7 +1048,7 @@ module Make (State : SState.S) : StateErr.EOther msg) result | Error err -> - let fail_pfs : Formula.t = State.get_failing_constraint err in + let fail_pfs : Expr.t = State.get_failing_constraint err in let failing_model = State.sat_check_f astate.state [ fail_pfs ] in let msg = @@ -1120,7 +1124,7 @@ module Make (State : SState.S) : L.verbose (fun fmt -> fmt "PSTATE.matches: Success: %b" success); success - let unfolding_vals (astate : t) (fs : Formula.t list) : vt list = + let unfolding_vals (astate : t) (fs : Expr.t list) : vt list = State.unfolding_vals astate.state fs let add_pred_defs (pred_defs : MP.preds_tbl_t) (astate : t) : t = @@ -1176,7 +1180,7 @@ module Make (State : SState.S) : let split_core_pred_further astate core_pred ins err = State.split_core_pred_further astate.state core_pred ins err - let mem_constraints (astate : t) : Formula.t list = + let mem_constraints (astate : t) : Expr.t list = State.mem_constraints astate.state let is_overlapping_asrt (a : string) : bool = State.is_overlapping_asrt a From 59b874bb8a901f5a89b43b391841f074e21e613e Mon Sep 17 00:00:00 2001 From: N1ark Date: Tue, 24 Dec 2024 18:15:00 +0100 Subject: [PATCH 31/54] Update Monadic --- GillianCore/monadic/FOSolver.ml | 13 ++++---- GillianCore/monadic/MonadicSMemory.ml | 6 ++-- GillianCore/monadic/branch.mli | 2 +- GillianCore/monadic/delayed.ml | 45 +++++++++++---------------- GillianCore/monadic/delayed.mli | 16 +++++----- GillianCore/monadic/pc.ml | 38 ++++++++++++---------- 6 files changed, 56 insertions(+), 64 deletions(-) diff --git a/GillianCore/monadic/FOSolver.ml b/GillianCore/monadic/FOSolver.ml index 9e8c10c1..60727a59 100644 --- a/GillianCore/monadic/FOSolver.ml +++ b/GillianCore/monadic/FOSolver.ml @@ -2,15 +2,15 @@ module FOSolver = Engine.FOSolver module PFS = Engine.PFS module Type_env = Engine.Type_env module Reduction = Engine.Reduction -module Formula = Gil_syntax.Formula +module Expr = Gil_syntax.Expr module Typing = Engine.Typing (** FIXME: optimization? *) let build_full_pfs (pc : Pc.t) = - if Formula.Set.is_empty pc.learned then pc.pfs + if Expr.Set.is_empty pc.learned then pc.pfs else let copied = PFS.copy pc.pfs in - Formula.Set.iter (PFS.extend copied) pc.learned; + Expr.Set.iter (PFS.extend copied) pc.learned; copied let build_full_gamma (pc : Pc.t) = @@ -22,7 +22,7 @@ let build_full_gamma (pc : Pc.t) = let sat ~(pc : Pc.t) formula = Logging.tmi (fun m -> - m "Monadic about to check sat of this new formula:@[%a@]" Formula.pp + m "Monadic about to check sat of this new formula:@[%a@]" Expr.pp formula); let pfs, gamma = (build_full_pfs pc, build_full_gamma pc) in @@ -36,8 +36,7 @@ let check_entailment ~(pc : Pc.t) formula = Engine.Reduction.reduce_formula ~matching:pc.matching ~gamma ~pfs formula in match f with - | True -> true - | False -> false + | Lit (Bool b) -> b | _ -> FOSolver.check_entailment ~matching:pc.matching Utils.Containers.SS.empty pfs [ f ] gamma @@ -46,7 +45,7 @@ let check_entailment ~(pc : Pc.t) formula = m "check_entailment: couldn't check due to an error reducing %a - %s\n\ Formula:%a" - Gil_syntax.Expr.pp e msg Formula.pp formula); + Gil_syntax.Expr.pp e msg Expr.pp formula); false let of_comp_fun comp ~(pc : Pc.t) e1 e2 = diff --git a/GillianCore/monadic/MonadicSMemory.ml b/GillianCore/monadic/MonadicSMemory.ml index c657baca..df4fdb96 100644 --- a/GillianCore/monadic/MonadicSMemory.ml +++ b/GillianCore/monadic/MonadicSMemory.ml @@ -43,10 +43,10 @@ module type S = sig val lvars : t -> Containers.SS.t val alocs : t -> Containers.SS.t val assertions : ?to_keep:Containers.SS.t -> t -> Asrt.t - val mem_constraints : t -> Formula.t list + val mem_constraints : t -> Expr.t list val get_recovery_tactic : t -> err_t -> vt Recovery_tactic.t val pp_err : Format.formatter -> err_t -> unit - val get_failing_constraint : err_t -> Formula.t + val get_failing_constraint : err_t -> Expr.t val get_fixes : err_t -> Asrt.t list val can_fix : err_t -> bool val pp_by_need : Containers.SS.t -> Format.formatter -> t -> unit @@ -94,7 +94,7 @@ module Lift (MSM : S) : Gbranch.{ pc = gpc; value } let substitution_in_place ~pfs ~gamma subst mem : - (t * Formula.Set.t * (string * Type.t) list) list = + (t * Expr.Set.t * (string * Type.t) list) list = let process = substitution_in_place subst mem in let curr_pc = Pc.make ~matching:false ~pfs ~gamma () in match Delayed.resolve ~curr_pc process with diff --git a/GillianCore/monadic/branch.mli b/GillianCore/monadic/branch.mli index 8c3d20b3..11b106b5 100644 --- a/GillianCore/monadic/branch.mli +++ b/GillianCore/monadic/branch.mli @@ -3,6 +3,6 @@ type 'a t = { pc : Pc.t; value : 'a } val make : pc:Pc.t -> value:'a -> 'a t val value : 'a t -> 'a val pc : 'a t -> Pc.t -val learned : 'a t -> Gil_syntax.Formula.Set.t +val learned : 'a t -> Gil_syntax.Expr.Set.t val learned_types : 'a t -> (string * Gil_syntax.Type.t) list val pp : 'a Fmt.t -> 'a t Fmt.t diff --git a/GillianCore/monadic/delayed.ml b/GillianCore/monadic/delayed.ml index 2f7c929a..d91971f3 100644 --- a/GillianCore/monadic/delayed.ml +++ b/GillianCore/monadic/delayed.ml @@ -1,14 +1,13 @@ -module Formula = Gil_syntax.Formula module Expr = Gil_syntax.Expr module Type = Gil_syntax.Type -exception NonExhaustiveEntailment of Formula.t list +exception NonExhaustiveEntailment of Expr.t list let () = Printexc.register_printer (function | NonExhaustiveEntailment fs -> let s = - Fmt.str "NonExhaustiveEntailment(%a)" (Fmt.Dump.list Formula.pp) fs + Fmt.str "NonExhaustiveEntailment(%a)" (Fmt.Dump.list Expr.pp) fs in Some s | _ -> None) @@ -34,13 +33,13 @@ let branches (x : 'a t list) : 'a t = fun ~curr_pc -> List.concat_map (fun (b : 'a t) -> b ~curr_pc) x let branch_on - (guard : Formula.t) + (guard : Expr.t) ~(then_ : unit -> 'a t) ~(else_ : unit -> 'a t) ~curr_pc = match guard with - | True -> then_ () ~curr_pc - | False -> else_ () ~curr_pc + | Lit (Bool true) -> then_ () ~curr_pc + | Lit (Bool false) -> else_ () ~curr_pc | guard -> ( try let guard_sat = FOSolver.sat ~pc:curr_pc guard in @@ -48,7 +47,7 @@ let branch_on else_ () ~curr_pc else let then_branches = then_ () ~curr_pc:(Pc.extend curr_pc [ guard ]) in - let not_guard = Formula.Infix.fnot guard in + let not_guard = Expr.Infix.not guard in if FOSolver.sat ~pc:curr_pc not_guard then let else_branches = else_ () ~curr_pc:(Pc.extend curr_pc [ not_guard ]) @@ -56,44 +55,36 @@ let branch_on then_branches @ else_branches else then_branches with Smt.SMT_unknown -> - Fmt.pr "TIMED OUT ON: %a" Formula.pp guard; + Fmt.pr "TIMED OUT ON: %a" Expr.pp guard; vanish () ~curr_pc) let if_sure - (guard : Formula.t) + (guard : Expr.t) ~(then_ : unit -> 'a t) ~(else_ : unit -> 'a t) ~curr_pc = match guard with - | True -> then_ () ~curr_pc - | False -> else_ () ~curr_pc + | Lit (Bool true) -> then_ () ~curr_pc + | Lit (Bool false) -> else_ () ~curr_pc | guard -> if FOSolver.check_entailment ~pc:curr_pc guard then let extended_pc = Pc.extend curr_pc [ guard ] in then_ () ~curr_pc:extended_pc else else_ () ~curr_pc -let branch_entailment (branches : (Formula.t * (unit -> 'a t)) list) ~curr_pc = - let rec loop l = - match l with +let branch_entailment (branches : (Expr.t * (unit -> 'a t)) list) ~curr_pc = + let rec loop = function | [] -> raise (NonExhaustiveEntailment (List.map fst branches)) - | (guard, thunk) :: r -> ( - match guard with - | Formula.True -> thunk () ~curr_pc - | False -> loop r - | _ -> - if FOSolver.check_entailment ~pc:curr_pc guard then - thunk () ~curr_pc - else loop r) + | (Expr.Lit (Bool true), thunk) :: _ -> thunk () ~curr_pc + | (Expr.Lit (Bool false), _) :: r -> loop r + | (guard, thunk) :: r -> + if FOSolver.check_entailment ~pc:curr_pc guard then thunk () ~curr_pc + else loop r in loop branches let map x f ~curr_pc = - List.map - (fun b -> - let open Branch in - { b with value = f b.value }) - (x ~curr_pc) + List.map (fun b -> Branch.{ b with value = f b.value }) (x ~curr_pc) let delayed_eval f x ~curr_pc = [ Branch.make ~pc:curr_pc ~value:(f ~pc:curr_pc x) ] diff --git a/GillianCore/monadic/delayed.mli b/GillianCore/monadic/delayed.mli index 014660ce..107dcb92 100644 --- a/GillianCore/monadic/delayed.mli +++ b/GillianCore/monadic/delayed.mli @@ -5,24 +5,22 @@ type 'a t val resolve : curr_pc:Pc.t -> 'a t -> 'a Branch.t list val return : - ?learned:Formula.t list -> ?learned_types:(string * Type.t) list -> 'a -> 'a t + ?learned:Expr.t list -> ?learned_types:(string * Type.t) list -> 'a -> 'a t val resolve_loc : Expr.t -> string option t val reduce : Expr.t -> Expr.t t -val reduce_formula : Formula.t -> Formula.t t -val entails : Formula.t list -> Formula.t -> bool t -val check_sat : Formula.t -> bool t +val reduce_formula : Expr.t -> Expr.t t +val entails : Expr.t list -> Expr.t -> bool t +val check_sat : Expr.t -> bool t val bind : 'a t -> ('a -> 'b t) -> 'b t val map : 'a t -> ('a -> 'b) -> 'b t val branches : 'a t list -> 'a t val all : 'a t list -> 'a list t val vanish : unit -> 'a t -val if_sure : Formula.t -> then_:(unit -> 'a t) -> else_:(unit -> 'a t) -> 'a t -val branch_entailment : (Formula.t * (unit -> 'a t)) list -> 'a t +val if_sure : Expr.t -> then_:(unit -> 'a t) -> else_:(unit -> 'a t) -> 'a t +val branch_entailment : (Expr.t * (unit -> 'a t)) list -> 'a t val leak_pc_copy : unit -> Engine.Gpc.t t - -val branch_on : - Formula.t -> then_:(unit -> 'a t) -> else_:(unit -> 'a t) -> 'a t +val branch_on : Expr.t -> then_:(unit -> 'a t) -> else_:(unit -> 'a t) -> 'a t module Syntax : sig val ( let* ) : 'a t -> ('a -> 'b t) -> 'b t diff --git a/GillianCore/monadic/pc.ml b/GillianCore/monadic/pc.ml index 449ad0a8..c6ea4bef 100644 --- a/GillianCore/monadic/pc.ml +++ b/GillianCore/monadic/pc.ml @@ -6,7 +6,7 @@ module FOSolver = Engine.FOSolver type t = { pfs : Pure_context.t; gamma : Type_env.t; - learned : Formula.Set.t; + learned : Expr.Set.t; learned_types : (string * Type.t) list; matching : bool; } @@ -21,7 +21,7 @@ let copy { pfs; gamma; learned; learned_types; matching } = } let make ~pfs ~gamma ~matching ?(learned = []) ?(learned_types = []) () = - { pfs; gamma; learned = Formula.Set.of_list learned; learned_types; matching } + { pfs; gamma; learned = Expr.Set.of_list learned; learned_types; matching } let init ?(matching = false) () = make ~pfs:(Pure_context.init ()) ~gamma:(Type_env.init ()) ~matching () @@ -36,12 +36,12 @@ let pfs_to_pfs_and_gamma pfs = in let rec aux = function | [] -> ([], []) - | Formula.Eq (UnOp (TypeOf, e), Lit (Type t)) :: r - | Eq (Lit (Type t), UnOp (TypeOf, e)) :: r -> ( + | Expr.BinOp (UnOp (TypeOf, e), Equal, Lit (Type t)) :: r + | BinOp (Lit (Type t), Equal, UnOp (TypeOf, e)) :: r -> ( let other_pfs, other_gamma = aux r in match expr_type_binding_to_gamma (e, t) with | None -> - ( Formula.Eq (Lit (Type t), UnOp (TypeOf, e)) :: other_pfs, + ( Expr.BinOp (Lit (Type t), Equal, UnOp (TypeOf, e)) :: other_pfs, other_gamma ) | Some gamma -> (other_pfs, gamma :: other_gamma)) | f :: r -> @@ -51,7 +51,13 @@ let pfs_to_pfs_and_gamma pfs = aux pfs let extend pc fs = - let fs = List.concat_map Formula.split_conjunct_formulae fs in + let rec split_conjunct : Expr.t -> Expr.t list = function + | BinOp (f1, And, f2) -> split_conjunct f1 @ split_conjunct f2 + | UnOp (Not, BinOp (f1, Or, f2)) -> + split_conjunct (BinOp (UnOp (Not, f1), And, UnOp (Not, f2))) + | f -> [ f ] + in + let fs = List.concat_map split_conjunct fs in let pfs, gamma = (pc.pfs, pc.gamma) in let fs = List.filter_map @@ -59,14 +65,14 @@ let extend pc fs = match Engine.Reduction.reduce_formula ~matching:pc.matching ~pfs ~gamma f with - | Formula.True -> None + | Expr.Lit (Bool true) -> None | f -> Some f) fs in let new_pfs, new_gamma = pfs_to_pfs_and_gamma fs in { pc with - learned = Formula.Set.add_seq (List.to_seq new_pfs) pc.learned; + learned = Expr.Set.add_seq (List.to_seq new_pfs) pc.learned; learned_types = new_gamma @ pc.learned_types; } @@ -74,10 +80,9 @@ let extend_types pc types = { pc with learned_types = types @ pc.learned_types } let equal pca pcb = pca.pfs = pcb.pfs && pca.gamma = pcb.gamma - && Formula.Set.equal pca.learned pcb.learned + && Expr.Set.equal pca.learned pcb.learned && List.for_all2 - (fun (n1, t1) (n2, t2) -> - String.equal n1 n2 && String.equal (Type.str t1) (Type.str t2)) + (fun (n1, t1) (n2, t2) -> String.equal n1 n2 && Type.equal t1 t2) pca.learned_types pcb.learned_types let pp = @@ -87,11 +92,11 @@ let pp = Fmt.field "pfs" (fun x -> x.pfs) (fun fmt pfs -> - (Fmt.Dump.list Formula.pp) fmt (Pure_context.to_list pfs)); + (Fmt.Dump.list Expr.pp) fmt (Pure_context.to_list pfs)); Fmt.field "gamma" (fun x -> x.gamma) Type_env.pp; Fmt.field "learned" - (fun x -> Formula.Set.to_seq x.learned) - (Fmt.Dump.seq Formula.pp); + (fun x -> Expr.Set.to_seq x.learned) + (Fmt.Dump.seq Expr.pp); Fmt.field "learned_types" (fun x -> x.learned_types) (Fmt.Dump.list @@ -99,8 +104,7 @@ let pp = ]) let diff pca pcb = - ( Formula.Set.diff pca.learned pcb.learned, - Formula.Set.diff pcb.learned pca.learned ) + (Expr.Set.diff pca.learned pcb.learned, Expr.Set.diff pcb.learned pca.learned) let of_gpc (gpc : Engine.Gpc.t) = let Engine.Gpc.{ pfs; gamma; matching } = gpc in @@ -110,6 +114,6 @@ let to_gpc (pc : t) = let { pfs; gamma; matching; learned; learned_types } = pc in let pfs = Pure_context.copy pfs in let gamma = Type_env.copy gamma in - Formula.Set.iter (Pure_context.extend pfs) learned; + Expr.Set.iter (Pure_context.extend pfs) learned; List.iter (fun (x, y) -> Type_env.update gamma x y) learned_types; Engine.Gpc.{ pfs; gamma; matching } From e9eb5a2e78ea89bd37e8438cc27ab3a21df320a1 Mon Sep 17 00:00:00 2001 From: N1ark Date: Tue, 24 Dec 2024 18:15:41 +0100 Subject: [PATCH 32/54] Update smt / GIL_Syntax --- GillianCore/GIL_Syntax/Expr.ml | 103 +++++++++++++++++++++- GillianCore/GIL_Syntax/Gil_syntax.mli | 20 ++++- GillianCore/smt/smt.ml | 122 +++++++------------------- GillianCore/smt/smt.mli | 8 +- 4 files changed, 153 insertions(+), 100 deletions(-) diff --git a/GillianCore/GIL_Syntax/Expr.ml b/GillianCore/GIL_Syntax/Expr.ml index 395b1b38..6672b9f2 100644 --- a/GillianCore/GIL_Syntax/Expr.ml +++ b/GillianCore/GIL_Syntax/Expr.ml @@ -29,6 +29,8 @@ let int n = lit (Int (Z.of_int n)) let int_z z = lit (Int z) let string s = lit (String s) let bool b = lit (Bool b) +let false_ = Lit (Bool false) +let true_ = Lit (Bool true) let zero_i = int_z Z.zero let one_i = int_z Z.one @@ -244,24 +246,73 @@ module Infix = struct | Lit (Bool a) -> Lit (Bool (not a)) | x -> UnOp (Not, x) + let ( == ) a b = + match (a, b) with + | Lit la, Lit lb -> bool (Literal.equal la lb) + | a, b when equal a b -> Lit (Bool true) + | _ -> BinOp (a, Equal, b) + + let lt = ( < ) + let lte = ( <= ) + let gt = ( > ) + let gte = ( >= ) + + let ( < ) a b = + match (a, b) with + | Lit (Int x), Lit (Int y) -> bool (lt x y) + | _ -> BinOp (a, ILessThan, b) + + let ( <= ) a b = + match (a, b) with + | Lit (Int x), Lit (Int y) -> bool (lte x y) + | _ -> BinOp (a, ILessThanEqual, b) + + let ( > ) a b = + match (a, b) with + | Lit (Int x), Lit (Int y) -> bool (gt x y) + | _ -> BinOp (b, ILessThanEqual, a) + + let ( >= ) a b = + match (a, b) with + | Lit (Int x), Lit (Int y) -> bool (gte x y) + | _ -> BinOp (b, ILessThan, a) + + let ( <. ) a b = + match (a, b) with + | Lit (Num x), Lit (Num y) -> bool (lt x y) + | _ -> BinOp (a, FLessThan, b) + + let ( <=. ) a b = + match (a, b) with + | Lit (Num x), Lit (Num y) -> bool (lte x y) + | _ -> BinOp (a, FLessThanEqual, b) + + let ( >. ) a b = + match (a, b) with + | Lit (Num x), Lit (Num y) -> bool (gt x y) + | _ -> BinOp (b, FLessThanEqual, a) + + let ( >=. ) a b = + match (a, b) with + | Lit (Num x), Lit (Num y) -> bool (gte x y) + | _ -> BinOp (b, FLessThan, a) + let ( && ) a b = match (a, b) with - | Lit (Bool x), Lit (Bool y) -> Lit (Bool (x && y)) | Lit (Bool true), x | x, Lit (Bool true) -> x | Lit (Bool false), _ | _, Lit (Bool false) -> Lit (Bool false) | _ -> BinOp (a, And, b) let ( || ) a b = match (a, b) with - | Lit (Bool x), Lit (Bool y) -> Lit (Bool (x || y)) | Lit (Bool false), x | x, Lit (Bool false) -> x | Lit (Bool true), _ | _, Lit (Bool true) -> Lit (Bool true) | _ -> BinOp (a, Or, b) let ( ==> ) a b = match (a, b) with - | Lit (Bool true), x | x, Lit (Bool true) -> x - | Lit (Bool false), _ -> Lit (Bool true) + | Lit (Bool true), x -> x + | Lit (Bool false), _ | _, Lit (Bool true) -> Lit (Bool true) | x, Lit (Bool false) -> not x | _ -> BinOp (a, Impl, b) @@ -495,6 +546,50 @@ and push_in_negations_on (a : t) : t = and push_in_negations (a : t) : t = push_in_negations_off a +(** Converts the given expression to a boolean expression, returning it and its negation. + Returns none if the expression cannot evaluate to a boolean. *) +let rec as_boolean_expr (e : t) : (t * t) option = + let open Syntaxes.Option in + let f = as_boolean_expr in + match e with + | LVar _ | PVar _ -> Some (BinOp (e, Equal, true_), BinOp (e, Equal, false_)) + | Lit (Bool b) -> Some (bool b, bool (not b)) + | BinOp (e1, FLessThan, e2) -> Some (e, BinOp (e2, FLessThanEqual, e1)) + | BinOp (e1, ILessThan, e2) -> Some (e, BinOp (e2, ILessThanEqual, e1)) + | BinOp (e1, FLessThanEqual, e2) -> Some (e, BinOp (e2, FLessThan, e1)) + | BinOp (e1, ILessThanEqual, e2) -> Some (e, BinOp (e2, ILessThan, e1)) + | BinOp (_, SetMem, _) + | BinOp (_, Equal, _) + | BinOp (_, StrLess, _) + | BinOp (_, SetSub, _) -> Some (e, UnOp (Not, e)) + | BinOp (e1, And, e2) -> + let* a1, na1 = f e1 in + let+ a2, na2 = f e2 in + (BinOp (a1, And, a2), BinOp (na1, Or, na2)) + | BinOp (e1, Or, e2) -> + let* a1, na1 = f e1 in + let+ a2, na2 = f e2 in + (BinOp (a1, Or, a2), BinOp (na1, And, na2)) + | BinOp (e1, Impl, e2) -> + let* a1, _ = f e1 in + let+ a2, na2 = f e2 in + (BinOp (a1, Impl, a2), BinOp (a1, And, na2)) + | UnOp (IsInt, _) -> Some (e, UnOp (Not, e)) + | UnOp (Not, e') -> + let+ a, na = f e' in + (na, a) + | Exists (bt, inner) -> + let+ inner, inner_neg = f inner in + let pos = Exists (bt, inner) in + let neg = ForAll (bt, inner_neg) in + (BinOp (pos, Equal, true_), neg) + | ForAll (bt, e) -> + let+ inner, inner_neg = f e in + let pos = ForAll (bt, inner) in + let neg = Exists (bt, inner_neg) in + (pos, BinOp (neg, Equal, true_)) + | _ -> None + let subst_expr_for_expr ~to_subst ~subst_with expr = let v = object diff --git a/GillianCore/GIL_Syntax/Gil_syntax.mli b/GillianCore/GIL_Syntax/Gil_syntax.mli index f0f02d18..809dbbcb 100644 --- a/GillianCore/GIL_Syntax/Gil_syntax.mli +++ b/GillianCore/GIL_Syntax/Gil_syntax.mli @@ -276,6 +276,8 @@ module Expr : sig val int_z : Z.t -> t val string : string -> t val bool : bool -> t + val false_ : t + val true_ : t val to_literal : t -> Literal.t option (** Lit (Int Z.zero) *) @@ -320,9 +322,21 @@ module Expr : sig (** {2: } *) + (** Comparison *) + + val ( < ) : t -> t -> t + val ( > ) : t -> t -> t + val ( <= ) : t -> t -> t + val ( >= ) : t -> t -> t + val ( <. ) : t -> t -> t + val ( >. ) : t -> t -> t + val ( <=. ) : t -> t -> t + val ( >=. ) : t -> t -> t + (** Booleans *) - val not : t -> t + val not : t -> t + val ( == ) : t -> t -> t val ( && ) : t -> t -> t val ( || ) : t -> t -> t val ( ==> ) : t -> t -> t @@ -382,6 +396,10 @@ module Expr : sig (** [push_in_negations e] negates e, recursively *) val push_in_negations : t -> t + (** Converts the given expression to a boolean expression, returning it and its negation. + Returns none if the expression cannot evaluate to a boolean. *) + val as_boolean_expr : t -> (t * t) option + (** [substitutables e] returns all lvars and alocs *) val substitutables : t -> SS.t diff --git a/GillianCore/smt/smt.ml b/GillianCore/smt/smt.ml index 1e0666c9..49fdee63 100644 --- a/GillianCore/smt/smt.ml +++ b/GillianCore/smt/smt.ml @@ -37,10 +37,10 @@ type typenv = (string, Type.t) Hashtbl.t let pp_typenv = Fmt.(Dump.hashtbl string (Fmt.of_to_string Type.str)) -let encoding_cache : (Formula.Set.t, sexp list) Hashtbl.t = +let encoding_cache : (Expr.Set.t, sexp list) Hashtbl.t = Hashtbl.create Config.big_tbl_size -let sat_cache : (Formula.Set.t, sexp option) Hashtbl.t = +let sat_cache : (Expr.Set.t, sexp option) Hashtbl.t = Hashtbl.create Config.big_tbl_size let ( <| ) constr e = app constr [ e ] @@ -564,14 +564,14 @@ let encode_binop (op : BinOp.t) (p1 : Encoding.t) (p2 : Encoding.t) : Encoding.t | FLessThan -> num_lt (get_num p1) (get_num p2) >- BooleanType | FLessThanEqual -> num_leq (get_num p1) (get_num p2) >- BooleanType | Equal -> encode_equality p1 p2 - | BOr -> bool_or (get_bool p1) (get_bool p2) >- BooleanType - | BImpl -> bool_implies (get_bool p1) (get_bool p2) >- BooleanType - | BAnd -> bool_and (get_bool p1) (get_bool p2) >- BooleanType - | BSetMem -> + | Or -> bool_or (get_bool p1) (get_bool p2) >- BooleanType + | Impl -> bool_implies (get_bool p1) (get_bool p2) >- BooleanType + | And -> bool_and (get_bool p1) (get_bool p2) >- BooleanType + | SetMem -> (* p2 has to be already wrapped *) set_member Z3 (simple_wrap p1) (get_set p2) >- BooleanType | SetDiff -> set_difference Z3 (get_set p1) (get_set p2) >- SetType - | BSetSub -> set_subset Z3 (get_set p1) (get_set p2) >- BooleanType + | SetSub -> set_subset Z3 (get_set p1) (get_set p2) >- BooleanType | LstNth -> seq_nth (get_list p1) (get_int p2) |> simply_wrapped | LstRepeat -> let x = simple_wrap p1 in @@ -583,7 +583,7 @@ let encode_binop (op : BinOp.t) (p1 : Encoding.t) (p2 : Encoding.t) : Encoding.t let res = Axiomatised_operations.snth $$ [ str'; index' ] in res >- StringType | FMod - | SLessThan + | StrLess | BitwiseAnd | BitwiseOr | BitwiseXor @@ -627,7 +627,7 @@ let encode_unop ~llen_lvars ~e (op : UnOp.t) le = | ToStringOp -> Axiomatised_operations.num2str <| get_num le >- StringType | ToNumberOp -> Axiomatised_operations.str2num <| get_string le >- NumberType | ToIntOp -> Axiomatised_operations.num2int <| get_num le >- NumberType - | UNot -> bool_not (get_bool le) >- BooleanType + | Not -> bool_not (get_bool le) >- BooleanType | Cdr -> let list = get_list le in seq_extract list (int_k 1) (seq_len list) >- ListType @@ -637,6 +637,7 @@ let encode_unop ~llen_lvars ~e (op : UnOp.t) le = | LstRev -> Axiomatised_operations.lrev <| get_list le >- ListType | NumToInt -> get_num le |> real_to_int >- IntType | IntToNum -> get_int le |> int_to_real >- NumberType + | IsInt -> num_divisible (get_num le) 1 >- BooleanType | BitwiseNot | M_isNaN | M_abs @@ -769,87 +770,28 @@ let rec encode_logical_expression | Exists (bt, e) -> encode_quantified_expr ~encode_expr:encode_logical_expression ~mk_quant:exists ~gamma ~llen_lvars ~list_elem_vars bt e - | EForall (bt, e) -> + | ForAll (bt, e) -> encode_quantified_expr ~encode_expr:encode_logical_expression ~mk_quant:forall ~gamma ~llen_lvars ~list_elem_vars bt e -and encode_assertion - ~(gamma : typenv) - ~(llen_lvars : SS.t) - ~(list_elem_vars : SS.t) - (a : Formula.t) : Encoding.t = - let f = encode_assertion ~gamma ~llen_lvars ~list_elem_vars in - let fe = encode_logical_expression ~gamma ~llen_lvars ~list_elem_vars in - let open Encoding in - match a with - | Not a -> - let>- a = f a in - get_bool a |> bool_not >- BooleanType - | Eq (le1, le2) -> encode_equality (fe le1) (fe le2) - | FLess (le1, le2) -> - let>- le1 = fe le1 in - let>- le2 = fe le2 in - num_lt (get_num le1) (get_num le2) >- BooleanType - | FLessEq (le1, le2) -> - let>- le1 = fe le1 in - let>- le2 = fe le2 in - num_leq (get_num le1) (get_num le2) >- BooleanType - | ILess (le1, le2) -> - let>- le1 = fe le1 in - let>- le2 = fe le2 in - num_lt (get_int le1) (get_int le2) >- BooleanType - | ILessEq (le1, le2) -> - let>- le1 = fe le1 in - let>- le2 = fe le2 in - num_leq (get_int le1) (get_int le2) >- BooleanType - | Impl (a1, a2) -> - let>- a1 = f a1 in - let>- a2 = f a2 in - bool_implies (get_bool a1) (get_bool a2) >- BooleanType - | StrLess (_, _) -> failwith "SMT encoding does not support STRLESS" - | True -> bool_k true >- BooleanType - | False -> bool_k false >- BooleanType - | Or (a1, a2) -> - let>- a1 = f a1 in - let>- a2 = f a2 in - bool_or (get_bool a1) (get_bool a2) >- BooleanType - | And (a1, a2) -> - let>- a1 = f a1 in - let>- a2 = f a2 in - bool_and (get_bool a1) (get_bool a2) >- BooleanType - | SetMem (le1, le2) -> - let>- le1 = fe le1 in - let>- le2 = fe le2 in - set_member Z3 (simple_wrap le1) (get_set le2) >- BooleanType - | SetSub (le1, le2) -> - let>- le1 = fe le1 in - let>- le2 = fe le2 in - set_subset Z3 (get_set le1) (get_set le2) >- BooleanType - | ForAll (bt, a) -> - encode_quantified_expr ~encode_expr:encode_assertion ~mk_quant:forall - ~gamma ~llen_lvars ~list_elem_vars bt a - | IsInt e -> - let>- e = fe e in - num_divisible (get_num e) 1 >- BooleanType - let encode_assertion_top_level ~(gamma : typenv) ~(llen_lvars : SS.t) ~(list_elem_vars : SS.t) - (a : Formula.t) : Encoding.t = + (a : Expr.t) : Encoding.t = try - encode_assertion ~gamma ~llen_lvars ~list_elem_vars - (Formula.push_in_negations a) + encode_logical_expression ~gamma ~llen_lvars ~list_elem_vars + (Expr.push_in_negations a) with e -> let s = Printexc.to_string e in let msg = - Fmt.str "Failed to encode %a in gamma %a with error %s\n" Formula.pp a + Fmt.str "Failed to encode %a in gamma %a with error %s\n" Expr.pp a pp_typenv gamma s in let () = L.print_to_all msg in raise e -let lvars_only_in_llen (fs : Formula.Set.t) : SS.t = +let lvars_only_in_llen (fs : Expr.Set.t) : SS.t = let inspector = object inherit [_] Visitors.iter as super @@ -864,10 +806,10 @@ let lvars_only_in_llen (fs : Formula.Set.t) : SS.t = | _ -> super#visit_expr () e end in - fs |> Formula.Set.iter (inspector#visit_formula ()); + fs |> Expr.Set.iter (inspector#visit_expr ()); inspector#get_diff -let lvars_as_list_elements (assertions : Formula.Set.t) : SS.t = +let lvars_as_list_elements (assertions : Expr.Set.t) : SS.t = let collector = object (self) inherit [_] Visitors.reduce @@ -877,7 +819,7 @@ let lvars_as_list_elements (assertions : Formula.Set.t) : SS.t = (* Quantified variables need to be excluded *) let univ_quant = List.to_seq binders |> Seq.map fst in let exclude = Containers.SS.add_seq univ_quant exclude in - self#visit_formula (exclude, is_in_list) f + self#visit_expr (exclude, is_in_list) f method! visit_Exists (exclude, is_in_list) binders e = let exist_quants = List.to_seq binders |> Seq.map fst in @@ -906,19 +848,19 @@ let lvars_as_list_elements (assertions : Formula.Set.t) : SS.t = method! visit_'annot _ () = self#zero end in - Formula.Set.fold + Expr.Set.fold (fun f acc -> - let new_lvars = collector#visit_formula (SS.empty, false) f in + let new_lvars = collector#visit_expr (SS.empty, false) f in SS.union new_lvars acc) assertions SS.empty -let encode_assertions (fs : Formula.Set.t) (gamma : typenv) : sexp list = +let encode_assertions (fs : Expr.Set.t) (gamma : typenv) : sexp list = let open Encoding in let- () = Hashtbl.find_opt encoding_cache fs in let llen_lvars = lvars_only_in_llen fs in let list_elem_vars = lvars_as_list_elements fs in let encoded = - Formula.Set.elements fs + Expr.Set.elements fs |> List.map (encode_assertion_top_level ~gamma ~llen_lvars ~list_elem_vars) in let consts = @@ -969,7 +911,7 @@ module Dump = struct Fmt.pf (Format.formatter_of_out_channel c) "GIL query:\nFS: %a\nGAMMA: %a\nEncoded as SMT Query:\n%a@?" - (Fmt.iter ~sep:Fmt.comma Formula.Set.iter Formula.pp) + (Fmt.iter ~sep:Fmt.comma Expr.Set.iter Expr.pp) fs pp_typenv gamma (Fmt.list ~sep:(Fmt.any "\n") Sexplib.Sexp.pp_hum) cmds) @@ -981,11 +923,11 @@ let reset_solver () = let () = cmd (push 1) in () -let exec_sat' (fs : Formula.Set.t) (gamma : typenv) : sexp option = +let exec_sat' (fs : Expr.Set.t) (gamma : typenv) : sexp option = let () = L.verbose (fun m -> m "@[About to check SAT of:@\n%a@]@\nwith gamma:@\n@[%a@]\n" - (Fmt.iter ~sep:(Fmt.any "@\n") Formula.Set.iter Formula.pp) + (Fmt.iter ~sep:(Fmt.any "@\n") Expr.Set.iter Expr.pp) fs pp_typenv gamma) in let () = reset_solver () in @@ -1017,7 +959,7 @@ let exec_sat' (fs : Formula.Set.t) (gamma : typenv) : sexp option = Solver:\n\ %a\n\ @?" - (Fmt.iter ~sep:(Fmt.any ", ") Formula.Set.iter Formula.pp) + (Fmt.iter ~sep:(Fmt.any ", ") Expr.Set.iter Expr.pp) fs pp_typenv gamma (Fmt.list ~sep:(Fmt.any "\n\n") Sexplib.Sexp.pp_hum) encoded_assertions @@ -1029,14 +971,14 @@ let exec_sat' (fs : Formula.Set.t) (gamma : typenv) : sexp option = in ret -let exec_sat (fs : Formula.Set.t) (gamma : typenv) : sexp option = +let exec_sat (fs : Expr.Set.t) (gamma : typenv) : sexp option = try exec_sat' fs gamma with UnexpectedSolverResponse _ as e -> let msg = Fmt.str "SMT failure!\n%s\n" (Printexc.to_string e ^ "\n") in let () = L.print_to_all msg in exit 1 -let check_sat (fs : Formula.Set.t) (gamma : typenv) : sexp option = +let check_sat (fs : Expr.Set.t) (gamma : typenv) : sexp option = match Hashtbl.find_opt sat_cache fs with | Some result -> let () = @@ -1049,13 +991,13 @@ let check_sat (fs : Formula.Set.t) (gamma : typenv) : sexp option = let ret = exec_sat fs gamma in let () = L.verbose (fun m -> - let f = Formula.conjunct (Formula.Set.elements fs) in - m "Adding to cache : @[%a@]" Formula.pp f) + let f = Expr.conjunct (Expr.Set.elements fs) in + m "Adding to cache : @[%a@]" Expr.pp f) in let () = Hashtbl.replace sat_cache fs ret in ret -let is_sat (fs : Formula.Set.t) (gamma : typenv) : bool = +let is_sat (fs : Expr.Set.t) (gamma : typenv) : bool = check_sat fs gamma |> Option.is_some let lift_model diff --git a/GillianCore/smt/smt.mli b/GillianCore/smt/smt.mli index e36aa397..18cebade 100644 --- a/GillianCore/smt/smt.mli +++ b/GillianCore/smt/smt.mli @@ -2,13 +2,11 @@ open Gil_syntax exception SMT_unknown -val exec_sat : - Formula.Set.t -> (string, Type.t) Hashtbl.t -> Sexplib.Sexp.t option - -val is_sat : Formula.Set.t -> (string, Type.t) Hashtbl.t -> bool +val exec_sat : Expr.Set.t -> (string, Type.t) Hashtbl.t -> Sexplib.Sexp.t option +val is_sat : Expr.Set.t -> (string, Type.t) Hashtbl.t -> bool val check_sat : - Formula.Set.t -> (string, Type.t) Hashtbl.t -> Sexplib.Sexp.t option + Expr.Set.t -> (string, Type.t) Hashtbl.t -> Sexplib.Sexp.t option val lift_model : Sexplib.Sexp.t -> From 5657f8016fca18a571ee92cee0898f117a573ce7 Mon Sep 17 00:00:00 2001 From: N1ark Date: Wed, 25 Dec 2024 12:51:28 +0100 Subject: [PATCH 33/54] Update Gillian-C --- Gillian-C/lib/MonadicSMemory.ml | 24 ++++---- Gillian-C/lib/MonadicSVal.ml | 95 ++++++++++++++--------------- Gillian-C/lib/SHeapTree.ml | 50 ++++++++-------- Gillian-C/lib/SVal.ml | 4 +- Gillian-C/lib/gil_logic_gen.ml | 103 ++++++++++++++------------------ Gillian-C/lib/gilgen.ml | 8 +-- 6 files changed, 132 insertions(+), 152 deletions(-) diff --git a/Gillian-C/lib/MonadicSMemory.ml b/Gillian-C/lib/MonadicSMemory.ml index 4a665c2f..1a0928d4 100644 --- a/Gillian-C/lib/MonadicSMemory.ml +++ b/Gillian-C/lib/MonadicSMemory.ml @@ -24,7 +24,7 @@ let resolve_or_create_loc_name (lvar_loc : Expr.t) : string Delayed.t = match loc_name with | None -> let new_loc_name = ALoc.alloc () in - let learned = [ Formula.Eq (ALoc new_loc_name, lvar_loc) ] in + let learned = [ Expr.BinOp (ALoc new_loc_name, Equal, lvar_loc) ] in Logging.verbose (fun fmt -> fmt "Couldn't resolve loc %a, created %s" Expr.pp lvar_loc new_loc_name); @@ -175,8 +175,8 @@ module Mem = struct let cons_array map loc ofs size chunk = let open DR.Syntax in let** loc_name = resolve_loc_result loc in - let open Formula.Infix in - if%sat size #<= (Expr.int 0) then + let open Expr.Infix in + if%sat size <= Expr.int 0 then DR.ok (map, MonadicSVal.SVArray.empty, Some Perm.Freeable) else let** tree = get_tree_res map loc_name (Some ofs) (Some chunk) in @@ -187,8 +187,8 @@ module Mem = struct let prod_array map loc ofs size chunk array perm = let open DR.Syntax in - let open Formula.Infix in - if%sat size #<= (Expr.int 0) then DR.ok map + let open Expr.Infix in + if%sat size <= Expr.int 0 then DR.ok map else let* loc_name = resolve_or_create_loc_name loc in let* tree = get_or_create_tree map loc_name in @@ -213,9 +213,9 @@ module Mem = struct let cons_simple ~sheap_consumer map loc low high = let open DR.Syntax in - let open Formula.Infix in + let open Expr.Infix in let** loc_name = resolve_loc_result loc in - if%sat high #<= low then DR.ok (map, Some Perm.Freeable) + if%sat high <= low then DR.ok (map, Some Perm.Freeable) else let** tree = get_tree_res map loc_name None None in let++ new_tree, perm = @@ -225,8 +225,8 @@ module Mem = struct let prod_simple ~sheap_producer map loc low high perm = let open DR.Syntax in - let open Formula.Infix in - if%sat high #<= low then DR.ok map + let open Expr.Infix in + if%sat high <= low then DR.ok map else let* loc_name = resolve_or_create_loc_name loc in let* tree = get_or_create_tree map loc_name in @@ -265,8 +265,8 @@ module Mem = struct let move map dst_loc dst_ofs src_loc src_ofs sz = let open DR.Syntax in - let open Formula.Infix in - if%sat sz #== (Expr.int 0) then DR.ok map + let open Expr.Infix in + if%sat sz == Expr.int 0 then DR.ok map else let** dst_loc_name = resolve_loc_result dst_loc in let** src_loc_name = resolve_loc_result src_loc in @@ -955,7 +955,7 @@ let get_fixes err = | InvalidLocation loc -> let new_loc = ALoc.alloc () in let new_expr = Expr.ALoc new_loc in - [ [ Asrt.Pure (Eq (new_expr, loc)) ] ] + [ [ Asrt.Pure (BinOp (new_expr, Equal, loc)) ] ] | SHeapTreeErr { at_locations; diff --git a/Gillian-C/lib/MonadicSVal.ml b/Gillian-C/lib/MonadicSVal.ml index 56ac6f4c..948ee341 100644 --- a/Gillian-C/lib/MonadicSVal.ml +++ b/Gillian-C/lib/MonadicSVal.ml @@ -8,38 +8,38 @@ module DR = Delayed_result exception NotACompCertValue of Expr.t module Patterns = struct - open Formula.Infix + open Expr.Infix let number e = let open Expr in - (typeof e) #== (type_ NumberType) + typeof e == type_ NumberType let integer e = let open Expr in - (typeof e) #== (type_ IntType) + typeof e == type_ IntType let int_typ, float_typ, single_typ, long_typ = let open Expr in let open CConstants.VTypes in let num_typ int_t typ_str x = - (typeof x) #== (type_ ListType) - #&& ((list_length x) #== (int 2)) - #&& ((list_nth x 0) #== (string typ_str)) - #&& ((typeof (list_nth x 1)) #== (type_ int_t)) + typeof x == type_ ListType + && list_length x == int 2 + && list_nth x 0 == string typ_str + && typeof (list_nth x 1) == type_ int_t in ( num_typ IntType int_type, num_typ NumberType float_type, num_typ NumberType single_type, num_typ IntType long_type ) - let undefined x = x #== (Expr.Lit Undefined) + let undefined x = x == Expr.Lit Undefined let obj x = let open Expr in - (typeof x) #== (type_ ListType) - #&& ((list_length x) #== (int 2)) - #&& ((typeof (list_nth x 0)) #== (type_ ObjectType)) - #&& ((typeof (list_nth x 1)) #== (type_ IntType)) + typeof x == type_ ListType + && list_length x == int 2 + && typeof (list_nth x 0) == type_ ObjectType + && typeof (list_nth x 1) == type_ IntType end let of_chunk_and_expr chunk e = @@ -72,11 +72,11 @@ let of_chunk_and_expr chunk e = Expr.pp e)) | Tlong -> return (SVlong e) | Tint -> - let open Formula.Infix in + let open Expr.Infix in let i k = Expr.int k in let learned = match chunk with - | Mint8unsigned -> [ (i 0) #<= e; e #<= (i 255) ] + | Mint8unsigned -> [ i 0 <= e; e <= i 255 ] | _ -> [] in return ~learned (SVint e) @@ -85,7 +85,7 @@ let of_chunk_and_expr chunk e = | Tany32 | Tany64 -> Fmt.failwith "Unhandled chunk: %a" Chunk.pp chunk) let of_gil_expr sval_e = - let open Formula.Infix in + let open Expr.Infix in let open Patterns in Logging.verbose (fun fmt -> fmt "OF_GIL_EXPR : %a" Expr.pp sval_e); let* sval_e = Delayed.reduce sval_e in @@ -101,7 +101,7 @@ let of_gil_expr sval_e = | Some l -> (l, []) | None -> let aloc = ALoc.alloc () in - let learned = [ loc_expr #== (ALoc aloc) ] in + let learned = [ loc_expr == ALoc aloc ] in (aloc, learned) in DO.some ~learned (Sptr (loc, ofs)) @@ -138,8 +138,8 @@ let to_gil_expr sval = List.map (fun (e, t) -> let open Expr in - let open Formula.Infix in - (typeof e) #== (type_ t)) + let open Expr.Infix in + typeof e == type_ t) typings in Delayed.return ~learned:typing_pfs exp @@ -174,10 +174,10 @@ module SVArray = struct let empty = Arr (EList []) let is_empty = - let open Formula.Infix in + let open Expr.Infix in function - | Arr e -> (Expr.list_length e) #== (Expr.int 0) - | _ -> False + | Arr e -> Expr.list_length e == Expr.int 0 + | _ -> Expr.false_ let sure_is_all_zeros = function | Arr (EList l) -> @@ -205,8 +205,8 @@ module SVArray = struct in let learned = List.map - (let open Formula.Infix in - fun (e, t) -> (Expr.typeof e) #== (Expr.type_ t)) + (let open Expr.Infix in + fun (e, t) -> Expr.typeof e == Expr.type_ t) gamma in (Expr.EList (List.rev rev_l), learned) @@ -221,7 +221,7 @@ module SVArray = struct | None -> Expr.list_length arr_exp | Some size -> size in - let open Formula.Infix in + let open Expr.Infix in let zero = Expr.int 0 in let size = Engine.Reduction.reduce_lexpr size in match size with @@ -231,16 +231,14 @@ module SVArray = struct let undefs = Expr.Lit (LList (List.init (Z.to_int x) (fun _ -> Literal.Undefined))) in - arr_exp #== undefs + arr_exp == undefs | _ -> Logging.verbose (fun fmt -> fmt "Undefined pf: not as concrete: %a" Expr.pp size); let i = LVar.alloc () in let i_e = Expr.LVar i in - forall - [ (i, Some IntType) ] - zero #<= i_e #&& (i_e #< size) - #=> ((Expr.list_nth_e arr_exp i_e) #== (Lit Undefined)) + forall [ (i, Some IntType) ] zero <= i_e + && i_e < size ==> (Expr.list_nth_e arr_exp i_e == Lit Undefined) let zeros_pf ?size arr_exp = let size = @@ -248,7 +246,7 @@ module SVArray = struct | None -> Expr.list_length arr_exp | Some size -> size in - let open Formula.Infix in + let open Expr.Infix in let size = Engine.Reduction.reduce_lexpr size in match size with | Lit (Int x) -> @@ -257,26 +255,24 @@ module SVArray = struct Expr.Lit (LList (List.init (Z.to_int x) (fun _ -> Literal.Int Z.zero))) in - arr_exp #== zeros + arr_exp == zeros | _ -> Logging.verbose (fun fmt -> fmt "Zeros pf: not as concrete: %a" Expr.pp size); - let is_zero e = e #== (Expr.int 0) in + let is_zero e = e == Expr.int 0 in let i = LVar.alloc () in let i_e = Expr.LVar i in let zero = Expr.int 0 in - forall - [ (i, Some IntType) ] - zero #<= i_e #&& (i_e #< size) - #=> (is_zero (Expr.list_nth_e arr_exp i_e)) + forall [ (i, Some IntType) ] zero <= i_e + && i_e < size ==> is_zero (Expr.list_nth_e arr_exp i_e) let to_arr_with_size arr s = - let open Formula.Infix in - let allocate_array_lvar (descr : ?size:Expr.t -> Expr.t -> Formula.t) = + let open Expr.Infix in + let allocate_array_lvar (descr : ?size:Expr.t -> Expr.t -> Expr.t) = let x = LVar.alloc () in let learned_types = [ (x, Gil_syntax.Type.ListType) ] in let x = Expr.LVar x in - let learned = [ (Expr.list_length x) #== s; descr ~size:s x ] in + let learned = [ Expr.list_length x == s; descr ~size:s x ] in Delayed.return ~learned ~learned_types x in match arr with @@ -343,14 +339,14 @@ module SVArray = struct | Lit (Int n) -> (Expr.EList (Utils.List_utils.make (Z.to_int n) concrete_single), []) | _ -> - let open Formula.Infix in + let open Expr.Infix in let arr = LVar.alloc () in let arr_e = Expr.LVar arr in let learned = let open Expr in [ - (typeof arr_e) #== (type_ ListType); - (list_length arr_e) #== size; + typeof arr_e == type_ ListType; + list_length arr_e == size; describing_pf arr_e; ] in @@ -358,12 +354,9 @@ module SVArray = struct in match svarr with | Arr e -> - let open Formula.Infix in + let open Expr.Infix in let learned = - [ - (Expr.typeof e) #== (Expr.type_ ListType); - (Expr.list_length e) #== size; - ] + [ Expr.typeof e == Expr.type_ ListType; Expr.list_length e == size ] in (e, learned) | AllZeros -> @@ -398,8 +391,8 @@ module SVArray = struct (function | Expr.Lit Undefined -> [] | x -> - let open Formula.Infix in - [ (i low) #<= x; x #<= (i high) ]) + let open Expr.Infix in + [ i low <= x; x <= i high ]) e in Delayed.return ~learned () @@ -411,8 +404,8 @@ module SVArray = struct List.concat (List.init (Z.to_int n) (fun k -> let x = Expr.list_nth e k in - let open Formula.Infix in - [ (i low) #<= x; x #<= (i high) ])) + let open Expr.Infix in + [ i low <= x; x <= i high ])) in Delayed.return ~learned () | _ -> Delayed.return ()) diff --git a/Gillian-C/lib/SHeapTree.ml b/Gillian-C/lib/SHeapTree.ml index 2e1698b2..f829ba75 100644 --- a/Gillian-C/lib/SHeapTree.ml +++ b/Gillian-C/lib/SHeapTree.ml @@ -87,18 +87,18 @@ module Range = struct (low, low + (sz_chunk * size)) let is_equal (la, ha) (lb, hb) = - let open Formula.Infix in - la #== lb #&& (ha #== hb) + let open Expr.Infix in + la == lb && ha == hb let is_inside (la, ha) (lb, hb) = - let open Formula.Infix in - lb #<= la #&& (ha #<= hb) + let open Expr.Infix in + lb <= la && ha <= hb let size (a, b) = Expr.Infix.( - ) b a let point_strictly_inside x (l, h) = - let open Formula.Infix in - l #< x #&& (x #< h) + let open Expr.Infix in + l < x && x < h let split_at (l, h) x = ((l, x), (x, h)) let lvars (a, b) = SS.union (Expr.lvars a) (Expr.lvars b) @@ -326,9 +326,8 @@ module Node = struct | Arr e -> let two_pow_8 i = Int.shift_left 1 (8 * i) in let open Expr.Infix in - let open Formula.Infix in (* FIXME: This assumes big endian *) - if%sat (Expr.list_length e) #== (Expr.int size) then + if%sat Expr.list_length e == Expr.int size then let bytes = List.init size (fun i -> Expr.list_nth e i) in let _, v = List.fold_left @@ -341,8 +340,7 @@ module Node = struct List.filter_map (function | Expr.Lit Undefined -> None - | byte -> - Some byte #>= (Expr.int 0) #&& (byte #<= (Expr.int 255))) + | byte -> Some (byte >= Expr.int 0 && byte <= Expr.int 255)) bytes in let* v = SVal.of_chunk_and_expr chunk v in @@ -655,14 +653,14 @@ module Tree = struct let rec split ~range t : (Node.t * t * t) Delayed.t = (* this function splits a tree and returns the node in the given range *) (* We're assuming that range is inside old_span *) - let open Formula.Infix in + let open Expr.Infix in let open Delayed.Syntax in let old_span = t.span in let ol, oh = old_span in let nl, nh = range in if%sat - log_string "ol #== nl"; - ol #== nl + log_string "ol == nl"; + ol == nl then let at = nh in let* left_node, right_node = Node.split ~span:old_span ~at t.node in @@ -672,8 +670,8 @@ module Tree = struct Delayed.return (left_node, left, right) else if%sat - log_string "oh #== nh"; - oh #== nh + log_string "oh == nh"; + oh == nh then let at = nl in let* left_node, right_node = Node.split ~span:old_span ~at t.node in @@ -694,12 +692,12 @@ module Tree = struct Delayed.return (node, left, right) let extend_if_needed t range = - let open Formula.Infix in + let open Expr.Infix in let open Delayed.Syntax in let rl, rh = range in let sl, sh = t.span in let* t_with_left = - if%sat rl #< sl then + if%sat rl < sl then let new_left_tree = make ~node:(NotOwned Totally) ~span:(rl, sl) () in let children = (new_left_tree, t) in Delayed.return @@ -708,7 +706,7 @@ module Tree = struct in let sl, _ = t_with_left.span in let* result = - if%sat rh #> sh then + if%sat rh > sh then let new_right_tree = make ~node:(NotOwned Totally) ~span:(sh, rh) () in let children = (t_with_left, new_right_tree) in Delayed.return @@ -1062,8 +1060,8 @@ module Tree = struct let sval, types = NSVal.to_gil_expr value in let types = List.map - (let open Formula.Infix in - fun (x, t) -> Asrt.Pure (Expr.typeof x) #== (Expr.type_ t)) + (let open Expr.Infix in + fun (x, t) -> Asrt.Pure (Expr.typeof x == Expr.type_ t)) types in CoreP.single ~loc ~ofs:low ~chunk ~sval ~perm :: types @@ -1169,7 +1167,7 @@ let alocs = function let is_in_bounds range bounds = match bounds with - | None -> Formula.True + | None -> Expr.true_ | Some bounds -> Range.is_inside range bounds let get_perm_at t ofs = @@ -1191,10 +1189,10 @@ let get_perm_at t ofs = let weak_valid_pointer (t : t) (ofs : Expr.t) : (bool, err) DR.t = let is_sure_false bounds ofs = - let open Formula.Infix in + let open Expr.Infix in match bounds with - | None -> Formula.False - | Some (low, high) -> ofs #< low #|| (ofs #> high) + | None -> Expr.false_ + | Some (low, high) -> ofs < low || ofs > high in match t with | Freed -> DR.ok false @@ -1405,8 +1403,8 @@ let _check_valid_alignment chunk ofs = let al = Chunk.align chunk in let al_expr = Expr.int al in let divides x y = - let open Formula.Infix in - Expr.(y #== (int 0)) #|| ((Expr.imod y x) #== (Expr.int 0)) + let open Expr.Infix in + Expr.(y == int 0) || Expr.imod y x == Expr.int 0 in if%sat divides al_expr ofs then DR.ok () else DR.error (InvalidAlignment { offset = ofs; alignment = al }) diff --git a/Gillian-C/lib/SVal.ml b/Gillian-C/lib/SVal.ml index fbf64662..b70db48e 100644 --- a/Gillian-C/lib/SVal.ml +++ b/Gillian-C/lib/SVal.ml @@ -75,11 +75,11 @@ let of_gil_expr_almost_concrete ?(gamma = Type_env.init ()) gexpr = Some (Sptr (loc, offset), []) | EList [ LVar loc; Lit (Int k) ] -> let aloc = ALoc.alloc () in - let new_pf = Formula.Eq (LVar loc, Expr.ALoc aloc) in + let new_pf = Expr.BinOp (LVar loc, Equal, Expr.ALoc aloc) in Some (Sptr (aloc, Lit (Int k)), [ new_pf ]) | EList [ LVar loc; LVar ofs ] when is_loc_ofs gamma loc ofs -> let aloc = ALoc.alloc () in - let new_pf = Formula.Eq (LVar loc, Expr.ALoc aloc) in + let new_pf = Expr.BinOp (LVar loc, Equal, Expr.ALoc aloc) in Some (Sptr (aloc, LVar ofs), [ new_pf ]) | EList [ Lit (String typ); value ] when String.equal typ int_type -> Some (SVint value, []) diff --git a/Gillian-C/lib/gil_logic_gen.ml b/Gillian-C/lib/gil_logic_gen.ml index e50a5cfd..03b8a682 100644 --- a/Gillian-C/lib/gil_logic_gen.ml +++ b/Gillian-C/lib/gil_logic_gen.ml @@ -5,8 +5,8 @@ open CLogic open Compcert open CompileState module Str_set = Gillian.Utils.Containers.SS -open Formula.Infix module CoreP = Constr.Core +open Expr.Infix let id_of_string = Camlcoq.intern_string let true_name = Camlcoq.extern_atom @@ -34,11 +34,12 @@ let rec split3_expr_comp = function let ( ++ ) = Expr.Infix.( + ) -let ( == ) e1 e2 = - match e1 #== e2 with - | True -> Asrt.Emp +let to_assrt_of_gen_form = function + | Expr.Lit (Bool true) -> Asrt.Emp | f -> Pure f +let ( #== ) e1 e2 = to_assrt_of_gen_form (e1 == e2) + let types t e = let static_error () = Fmt.failwith "Statically infered that %a should be of type %s" Expr.pp e @@ -55,13 +56,6 @@ let types t e = static_error () (* Maybe a more precise message ? *) | _ -> Emp -let fold_and l = List.fold_left (fun a b -> a #&& b) Formula.True l - -let to_assrt_of_gen_form f = - match f with - | Formula.True -> Asrt.Emp - | _ -> Pure f - type gil_annots = { preds : Pred.t list; specs : Spec.t list; @@ -88,7 +82,9 @@ let get_structs_not_annot struct_types = let struct_names = List.map get_name struct_types in let already_annot = !already_annot_structs in let structs_not_annot = - List.filter (fun name -> not (Str_set.mem name already_annot)) struct_names + List.filter + (fun name -> Stdlib.not (Str_set.mem name already_annot)) + struct_names in let newly_annot = Str_set.union already_annot (Str_set.of_list structs_not_annot) @@ -143,11 +139,9 @@ let assert_of_member cenv members id typ = in let args_without_ins = List.init arg_number (fun k -> - Expr.LVar ("#i__" ^ field_name ^ "_" ^ string_of_int k)) - in - let list_is_components = - Formula.Infix.(Asrt.Pure pvmember #== (Expr.list args_without_ins)) + Expr.LVar ("i__" ^ field_name ^ "_" ^ string_of_int k)) in + let list_is_components = pvmember #== (Expr.list args_without_ins) in let ofs = Expr.Infix.(pvofs + fo) in let args = pvloc :: ofs :: args_without_ins in let pred_call = Asrt.Pred (pred_name, args) in @@ -166,7 +160,7 @@ let assert_of_member cenv members id typ = ] | _ -> let mk t v = Expr.list [ Expr.string t; v ] in - let field_val_name = "#i__" ^ field_name ^ "_v" in + let field_val_name = "i__" ^ field_name ^ "_v" in let lvval = Expr.LVar field_val_name in let e_to_use, getter_or_type_pred = let open Internal_Predicates in @@ -255,7 +249,8 @@ let gen_pred_of_struct cenv ann struct_name = | Member_plain (ida, t) :: (Member_plain (idb, _) :: _ as r) -> let end_a = Z.add (fo ida) (sz t) in let start_b = fo idb in - if end_a < start_b then (end_a, start_b) :: get_holes r else get_holes r + if Stdlib.( < ) end_a start_b then (end_a, start_b) :: get_holes r + else get_holes r | _ -> failwith "Unsupported bitfield members" in @@ -283,35 +278,31 @@ let gen_pred_of_struct cenv ann struct_name = in { ann with preds = n_pred :: ann.preds } -let trans_binop b = - match b with - | CBinOp.LstCons -> failwith "LstCons shouldn't be compiled that way" +let trans_binop : CBinOp.t -> BinOp.t = function + | LstCons -> failwith "LstCons shouldn't be compiled that way" | LstCat -> failwith "LstCat shouldn't be compiled that way" | PtrPlus -> failwith "PtrPlus shouldn't be compiled that way" - | Plus -> BinOp.IPlus - | Times -> BinOp.ITimes - | Minus -> BinOp.IMinus - | Div -> BinOp.IDiv + | Plus -> IPlus + | Times -> ITimes + | Minus -> IMinus + | Div -> IDiv | Equal -> Equal - | SetSub -> BSetSub + | SetSub -> SetSub | SetDiff -> SetDiff - | SetMem -> BSetMem + | SetMem -> SetMem | LessThan -> ILessThan - | And -> BAnd - | Or -> BOr + | And -> And + | Or -> Or -let trans_unop u = - match u with - | CUnOp.LstLen -> UnOp.LstLen - | Not -> UNot +let trans_unop : CUnOp.t -> UnOp.t = function + | LstLen -> LstLen + | Not -> Not -let trans_nop n = - match n with - | CNOp.SetUnion -> NOp.SetUnion +let trans_nop : CNOp.t -> NOp.t = function + | SetUnion -> SetUnion -let trans_simpl_expr se = - match se with - | CSimplExpr.PVar s -> Expr.PVar s +let trans_simpl_expr : CSimplExpr.t -> Expr.t = function + | PVar s -> PVar s | LVar s -> LVar s | Loc s -> Lit (Loc s) | Int i -> Lit (Int i) @@ -398,42 +389,40 @@ let rec trans_expr (e : CExpr.t) : Asrt.t * Var.t list * Expr.t = let a3, v3, len = trans_expr len in (a1 @ a2 @ a3, v1 @ v2 @ v3, Expr.list_sub ~lst ~start ~size:len) -let rec trans_form (f : CFormula.t) : Asrt.t * Var.t list * Formula.t = - let open Formula.Infix in - match f with - | CFormula.True -> ([], [], Formula.True) - | False -> ([], [], False) +let rec trans_form : CFormula.t -> Asrt.t * Var.t list * Expr.t = function + | True -> ([], [], Expr.true_) + | False -> ([], [], Expr.false_) | Eq (ce1, ce2) -> let f1, v1, eg1 = trans_expr ce1 in let f2, v2, eg2 = trans_expr ce2 in - (f1 @ f2, v1 @ v2, eg1 #== eg2) + (f1 @ f2, v1 @ v2, eg1 == eg2) | LessEq (ce1, ce2) -> let f1, v1, eg1 = trans_expr ce1 in let f2, v2, eg2 = trans_expr ce2 in - (f1 @ f2, v1 @ v2, eg1 #<= eg2) + (f1 @ f2, v1 @ v2, eg1 <= eg2) | Less (ce1, ce2) -> let f1, v1, eg1 = trans_expr ce1 in let f2, v2, eg2 = trans_expr ce2 in - (f1 @ f2, v1 @ v2, eg1 #< eg2) + (f1 @ f2, v1 @ v2, eg1 < eg2) | SetMem (ce1, ce2) -> let f1, v1, eg1 = trans_expr ce1 in let f2, v2, eg2 = trans_expr ce2 in - (f1 @ f2, v1 @ v2, SetMem (eg1, eg2)) + (f1 @ f2, v1 @ v2, BinOp (eg1, SetMem, eg2)) | Not fp -> let a, v, fpp = trans_form fp in - (a, v, fnot fpp) + (a, v, not fpp) | Or (f1, f2) -> let a1, v1, fp1 = trans_form f1 in let a2, v2, fp2 = trans_form f2 in - (a1 @ a2, v1 @ v2, fp1 #|| fp2) + (a1 @ a2, v1 @ v2, fp1 || fp2) | And (f1, f2) -> let a1, v1, fp1 = trans_form f1 in let a2, v2, fp2 = trans_form f2 in - (a1 @ a2, v1 @ v2, fp1 #&& fp2) + (a1 @ a2, v1 @ v2, fp1 && fp2) | Implies (f1, f2) -> let a1, v1, fp1 = trans_form f1 in let a2, v2, fp2 = trans_form f2 in - (a1 @ a2, v1 @ v2, fp1 #=> fp2) + (a1 @ a2, v1 @ v2, fp1 ==> fp2) | ForAll (lvts, f) -> let a, v, fp = trans_form f in (a, v, ForAll (lvts, fp)) @@ -795,7 +784,7 @@ let trans_spec ~ann ?(only_spec = false) cl_spec = spec_sspecs = List.map (trans_sspec ~ann fname) sspecs; spec_normalised = false; spec_incomplete = false; - spec_to_verify = not only_spec; + spec_to_verify = Stdlib.not only_spec; } in let _ = @@ -873,7 +862,7 @@ let bit_size = function | IBool -> 1 let bounds signedness bit_size = - let bit_size_m_1 = bit_size - 1 in + let bit_size_m_1 = Stdlib.( - ) bit_size 1 in let open Z in let min, max = match signedness with @@ -904,7 +893,7 @@ let predicate_from_triple (e, csmt, ct) = (PrintAST.name_of_type csmt)) let simple_predicate_from_triple (pn, _, _) = - Asrt.Pure (Eq (Expr.PVar pn, Expr.LVar ("#" ^ pn))) + Asrt.Pure (BinOp (Expr.PVar pn, Equal, Expr.LVar ("" ^ pn))) let generate_bispec clight_prog fname ident f = let rec combine a b c = @@ -918,11 +907,11 @@ let generate_bispec clight_prog fname ident f = let true_params = List.map true_name params in let clight_fun = get_clight_fun clight_prog ident in let cligh_params = clight_fun.Clight.fn_params in - let mk_lvar x = Expr.LVar ("#" ^ x) in + let mk_lvar x = Expr.LVar ("" ^ x) in let lvars = List.map mk_lvar true_params in let equalities = List.map - (fun x -> Asrt.Pure (Formula.Eq (Expr.PVar x, mk_lvar x))) + (fun x -> Asrt.Pure (Expr.BinOp (Expr.PVar x, Equal, mk_lvar x))) true_params in (* Right now, triples are : (param_name, csharpminor type, c type) diff --git a/Gillian-C/lib/gilgen.ml b/Gillian-C/lib/gilgen.ml index c4d7f8ae..0fd2c4cd 100644 --- a/Gillian-C/lib/gilgen.ml +++ b/Gillian-C/lib/gilgen.ml @@ -525,13 +525,13 @@ let rec trans_stmt ~clight_prog ~fname ~fid ~context stmt : | Scall (None, _, ex, [ e ]) when is_assert_call ex -> let cmds, egil = trans_expr e in let one = Expr.EList [ Lit (String VTypes.int_type); Expr.one_i ] in - let form = Formula.Eq (egil, one) in + let form = Expr.BinOp (egil, Equal, one) in let assert_cmd = Cmd.Logic (Assert form) in (add_annots ~ctx:context (cmds @ [ assert_cmd ]), []) | Scall (None, _, ex, [ e ]) when is_assume_call ex -> let cmds, egil = trans_expr e in let one = Expr.EList [ Lit (String VTypes.int_type); Expr.one_i ] in - let form = Formula.Eq (egil, one) in + let form = Expr.BinOp (egil, Equal, one) in let assume_cmd = Cmd.Logic (Assume form) in (add_annots ~ctx:context (cmds @ [ assume_cmd ]), []) | Scall (Some id, _, ex, []) when is_nondet_int_call ex -> @@ -600,9 +600,9 @@ let rec trans_stmt ~clight_prog ~fname ~fid ~context stmt : | LScons (None, _, r) -> build_isdefault curr r | LScons (Some l, _, r) -> let ne = - Expr.UnOp (UnOp.UNot, Expr.BinOp (guard_expr, BinOp.Equal, num l)) + Expr.UnOp (UnOp.Not, Expr.BinOp (guard_expr, BinOp.Equal, num l)) in - build_isdefault (Expr.BinOp (ne, BinOp.BAnd, curr)) r + build_isdefault (Expr.BinOp (ne, BinOp.And, curr)) r in let rec make_switch had_default l_stmts = match l_stmts with From a829b9536df43cd0895d168175a96f9dc2fd2fc0 Mon Sep 17 00:00:00 2001 From: N1ark Date: Wed, 25 Dec 2024 12:51:45 +0100 Subject: [PATCH 34/54] Update Gillian-C2 --- Gillian-C2/lib/compiler/compile_expr.ml | 44 ++++++++-------- Gillian-C2/lib/compiler/logics.ml | 14 +++-- Gillian-C2/lib/memory_model/GEnv.ml | 8 +-- Gillian-C2/lib/memory_model/MonadicSMemory.ml | 26 +++++----- Gillian-C2/lib/memory_model/SHeapTree.ml | 52 +++++++++---------- Gillian-C2/lib/memory_model/SVal.ml | 36 ++++++------- 6 files changed, 87 insertions(+), 93 deletions(-) diff --git a/Gillian-C2/lib/compiler/compile_expr.ml b/Gillian-C2/lib/compiler/compile_expr.ml index c69da993..d4cfdb32 100644 --- a/Gillian-C2/lib/compiler/compile_expr.ml +++ b/Gillian-C2/lib/compiler/compile_expr.ml @@ -199,13 +199,13 @@ let compile_binop | Some (low, high) -> (low, high)) in let ( <= ) a b = Expr.BinOp (a, ILessThanEqual, b) in - let ( && ) a b = Expr.BinOp (a, BAnd, b) in + let ( && ) a b = Expr.BinOp (a, And, b) in Expr.int_z low <= e && e <= Expr.int_z high in let assert_int_in_bounds ~ty e = let expr_cond = int_in_bounds ~ty e in let formula = - match Formula.lift_logic_expr expr_cond with + match Expr.as_boolean_expr expr_cond with | Some (f, _) -> f | _ -> Error.code_error @@ -344,8 +344,8 @@ let compile_binop | CInteger _ | Unsignedbv _ | Signedbv _ -> GilBinop IMod | Float -> GilBinop FMod | _ -> Unhandled `With_type) - | Or -> GilBinop BinOp.BOr - | And -> GilBinop BinOp.BAnd + | Or -> GilBinop BinOp.Or + | And -> GilBinop BinOp.And | OverflowPlus -> ( let int_check = GilBinop IPlus ||> int_in_bounds ~ty:lty ||> Expr.Infix.not @@ -424,8 +424,8 @@ let rec assume_type ~ctx (type_ : GType.t) (expr : Expr.t) : unit Cs.with_cmds = (* Special case, the bounds are different *) let assume_int = Cmd.Logic (AssumeType (expr, IntType)) in let condition = - let open Formula.Infix in - expr #== Expr.one_i #|| (expr #== Expr.zero_i) + let open Expr.Infix in + expr == Expr.one_i || expr == Expr.zero_i in let assume_range = Cmd.Logic (Assume condition) in Cs.return ~app:[ assume_int; assume_range ] () @@ -438,10 +438,8 @@ let rec assume_type ~ctx (type_ : GType.t) (expr : Expr.t) : unit Cs.with_cmds = match bounds with | None -> [] | Some (low, high) -> - let open Formula.Infix in - let condition = - (Expr.int_z low) #<= expr #&& (expr #<= (Expr.int_z high)) - in + let open Expr.Infix in + let condition = Expr.int_z low <= expr && expr <= Expr.int_z high in [ Cmd.Logic (Assume condition) ] in Cs.unit (assume_int :: assume_range) @@ -454,7 +452,7 @@ let rec assume_type ~ctx (type_ : GType.t) (expr : Expr.t) : unit Cs.with_cmds = let e_loc = Expr.PVar loc in let e_ofs = Expr.PVar ofs in let assume_list = - let f = Formula.Eq (expr, EList [ e_loc; e_ofs ]) in + let f = Expr.BinOp (expr, Equal, EList [ e_loc; e_ofs ]) in Cmd.Logic (Assume f) in let assume_obj = Cmd.Logic (AssumeType (e_loc, ObjectType)) in @@ -544,8 +542,8 @@ let rec nondet_expr ~ctx ~loc ~type_ ~display () : Val_repr.t Cs.with_body = let variant_number = Expr.int variant_amount in let variant_int = LCmd.AssumeType (variant, IntType) in let variant_constraint = - let open Formula.Infix in - Expr.zero_i #<= variant #&& (variant #< variant_number) + let open Expr.Infix in + Expr.zero_i <= variant && variant < variant_number in let variant_value = LCmd.Assume variant_constraint in Cs.return @@ -861,11 +859,11 @@ and compile_call else Cs.return to_assume in let f = - match Formula.lift_logic_expr to_assume with + match Expr.as_boolean_expr to_assume with | None -> Logging.normal ~severity:Warning (fun m -> m "Cannot assume %a, assuming False instead" Expr.pp to_assume); - Formula.False + Expr.false_ | Some (f, _) -> f in by_value ~app:[ b (Logic (Assume f)) ] (Lit Null) @@ -902,11 +900,11 @@ and compile_call else Cs.return to_assert in let f = - match Formula.lift_logic_expr to_assert with + match Expr.as_boolean_expr to_assert with | None -> Logging.normal ~severity:Warning (fun m -> m "Cannot assert %a, asserting False instead" Expr.pp to_assert); - Formula.False + Expr.false_ | Some (f, _) -> f in by_value ~app:[ b (Logic (Assert f)) ] (Expr.Lit Null) @@ -1132,13 +1130,13 @@ and compile_address_of ~ctx ~b (expr : GExpr.t) x = *) assert ctx.machine.null_is_zero; let assume_not_null = - let open Formula.Infix in - b (Cmd.Logic (Assume (fnot ptr #== Expr.zero_i))) + let open Expr.Infix in + b (Cmd.Logic (Assume (not (ptr == Expr.zero_i)))) in let assume_align_8 = - let open Formula.Infix in + let open Expr.Infix in let mod_8 = Expr.BinOp (ptr, IMod, Expr.int 8) in - b (Cmd.Logic (Assume mod_8 #== Expr.zero_i)) + b (Cmd.Logic (Assume (mod_8 == Expr.zero_i))) in Cs.return ~app:[ assume_not_null; assume_align_8 ] (Val_repr.ByValue ptr) (* Should probably just return a long, with a nondet value that has the right offset *) @@ -1474,7 +1472,7 @@ and compile_statement ~ctx (stmt : Stmt.t) : Val_repr.t Cs.with_body = ~subst_with:(Expr.Lit (Bool true)) e in let f = - match Formula.lift_logic_expr e with + match Expr.as_boolean_expr e with | None -> Error.code_error (Fmt.str "Unable to lift: %a" Expr.pp e) | Some (f, _) -> f in @@ -1496,7 +1494,7 @@ and compile_statement ~ctx (stmt : Stmt.t) : Val_repr.t Cs.with_body = ~subst_with:(Expr.Lit (Bool false)) e in let f = - match Formula.lift_logic_expr e with + match Expr.as_boolean_expr e with | None -> Error.code_error (Fmt.str "Unable to lift: %a" Expr.pp e) | Some (f, _) -> f in diff --git a/Gillian-C2/lib/compiler/logics.ml b/Gillian-C2/lib/compiler/logics.ml index 4f9915ae..5d481c60 100644 --- a/Gillian-C2/lib/compiler/logics.ml +++ b/Gillian-C2/lib/compiler/logics.ml @@ -7,8 +7,8 @@ let rec asrt_of_scalar_like ~ctx (type_ : GType.t) (expr : Expr.t) : Asrt.t = (* Special case, the bounds are different *) let assume_int = Asrt.Types [ (expr, IntType) ] in let condition = - let open Formula.Infix in - expr #== Expr.one_i #|| (expr #== Expr.zero_i) + let open Expr.Infix in + expr == Expr.one_i || expr == Expr.zero_i in let asrt_range = Asrt.Pure condition in [ assume_int; asrt_range ] @@ -21,10 +21,8 @@ let rec asrt_of_scalar_like ~ctx (type_ : GType.t) (expr : Expr.t) : Asrt.t = match bounds with | None -> Asrt.Emp | Some (low, high) -> - let open Formula.Infix in - let condition = - (Expr.int_z low) #<= expr #&& (expr #<= (Expr.int_z high)) - in + let open Expr.Infix in + let condition = Expr.int_z low <= expr && expr <= Expr.int_z high in Asrt.Pure condition in [ assume_int; assume_range ] @@ -35,7 +33,7 @@ let rec asrt_of_scalar_like ~ctx (type_ : GType.t) (expr : Expr.t) : Asrt.t = let e_loc = Expr.LVar loc in let e_ofs = Expr.LVar ofs in let assume_list = - let f = Formula.Eq (expr, EList [ e_loc; e_ofs ]) in + let f = Expr.BinOp (expr, Equal, EList [ e_loc; e_ofs ]) in Asrt.Pure f in let types = Asrt.Types [ (e_loc, ObjectType); (e_ofs, IntType) ] in @@ -57,7 +55,7 @@ let assumption_of_param ~ctx ~(v : Var.t) ~(ty : GType.t) = with [Compiled_expr.nondet_expr] *) if Ctx.representable_in_store ctx ty then let e_s = Expr.LVar (LVar.alloc ()) in - let f = Formula.Eq (Expr.PVar v, e_s) in + let f = Expr.BinOp (Expr.PVar v, Equal, e_s) in Asrt.Pure f :: asrt_of_scalar_like ~ctx ty e_s else failwith "unhandled: composit parameter" diff --git a/Gillian-C2/lib/memory_model/GEnv.ml b/Gillian-C2/lib/memory_model/GEnv.ml index 6906b027..8b0fef6b 100644 --- a/Gillian-C2/lib/memory_model/GEnv.ml +++ b/Gillian-C2/lib/memory_model/GEnv.ml @@ -16,10 +16,10 @@ module Make (Def_value : sig end) (Delayed_hack : sig type 'a t - val ( #== ) : Def_value.t -> Def_value.t -> Gil_syntax.Formula.t list + val ( #== ) : Def_value.t -> Def_value.t -> Gil_syntax.Expr.t list val return : - ?learned:Gil_syntax.Formula.t list -> + ?learned:Gil_syntax.Expr.t list -> ?learned_types:(string * Gil_syntax.Type.t) list -> 'a -> 'a t @@ -280,8 +280,8 @@ module Symbolic = let ( let+ ) = map let ( #== ) a b = - let open Gil_syntax.Formula.Infix in - [ a #== b ] + let open Gil_syntax.Expr.Infix in + [ a == b ] let resolve_or_create_lt lvar_loc : string t = let open Syntax in diff --git a/Gillian-C2/lib/memory_model/MonadicSMemory.ml b/Gillian-C2/lib/memory_model/MonadicSMemory.ml index 1b416490..9122e480 100644 --- a/Gillian-C2/lib/memory_model/MonadicSMemory.ml +++ b/Gillian-C2/lib/memory_model/MonadicSMemory.ml @@ -19,7 +19,7 @@ let resolve_or_create_loc_name (lvar_loc : Expr.t) : string Delayed.t = match loc_name with | None -> let new_loc_name = ALoc.alloc () in - let learned = [ Formula.Eq (ALoc new_loc_name, lvar_loc) ] in + let learned = [ Expr.BinOp (ALoc new_loc_name, Equal, lvar_loc) ] in Logging.verbose (fun fmt -> fmt "Couldn't resolve loc %a, created %s" Expr.pp lvar_loc new_loc_name); @@ -180,8 +180,8 @@ module Mem = struct let open DR.Syntax in let** loc_name = resolve_loc_result loc in - let open Formula.Infix in - if%sat size #<= (Expr.int 0) then DR.error (NonPositiveArraySize size) + let open Expr.Infix in + if%sat size <= Expr.int 0 then DR.error (NonPositiveArraySize size) else let** tree = get_tree_res map loc_name in let++ sarr, perm, new_tree = @@ -193,8 +193,8 @@ module Mem = struct let open DR.Syntax in let** loc_name = resolve_loc_result loc in - let open Formula.Infix in - if%sat size #<= (Expr.int 0) then DR.error (NonPositiveArraySize size) + let open Expr.Infix in + if%sat size <= Expr.int 0 then DR.error (NonPositiveArraySize size) else let** tree = get_tree_res map loc_name in let++ sarr, perm, new_tree = @@ -204,8 +204,8 @@ module Mem = struct let prod_array map loc ofs size chunk array perm = let open DR.Syntax in - let open Formula.Infix in - if%sat size #<= (Expr.int 0) then DR.ok map + let open Expr.Infix in + if%sat size <= Expr.int 0 then DR.ok map else let* loc_name = resolve_or_create_loc_name loc in let* tree = get_or_create_tree map loc_name in @@ -231,9 +231,9 @@ module Mem = struct let cons_simple ~sheap_consumer map loc low high = let open DR.Syntax in - let open Formula.Infix in + let open Expr.Infix in let** loc_name = resolve_loc_result loc in - if%sat high #<= low then DR.ok (map, Some Perm.Freeable) + if%sat high <= low then DR.ok (map, Some Perm.Freeable) else let** tree = get_tree_res map loc_name in let++ new_tree, perm = @@ -243,8 +243,8 @@ module Mem = struct let prod_simple ~sheap_producer map loc low high perm = let open DR.Syntax in - let open Formula.Infix in - if%sat high #<= low then DR.ok map + let open Expr.Infix in + if%sat high <= low then DR.ok map else let* loc_name = resolve_or_create_loc_name loc in let* tree = get_or_create_tree map loc_name in @@ -287,8 +287,8 @@ module Mem = struct let move map dst_loc dst_ofs src_loc src_ofs sz = let open DR.Syntax in - let open Formula.Infix in - if%sat sz #== (Expr.int 0) then DR.ok map + let open Expr.Infix in + if%sat sz == Expr.int 0 then DR.ok map else let** dst_loc_name = resolve_loc_result dst_loc in let** src_loc_name = resolve_loc_result src_loc in diff --git a/Gillian-C2/lib/memory_model/SHeapTree.ml b/Gillian-C2/lib/memory_model/SHeapTree.ml index 453356ac..16560cbc 100644 --- a/Gillian-C2/lib/memory_model/SHeapTree.ml +++ b/Gillian-C2/lib/memory_model/SHeapTree.ml @@ -98,18 +98,18 @@ module Range = struct (low, low + (sz_chunk * size)) let is_equal (la, ha) (lb, hb) = - let open Formula.Infix in - la #== lb #&& (ha #== hb) + let open Expr.Infix in + la == lb && ha == hb let is_inside (la, ha) (lb, hb) = - let open Formula.Infix in - lb #<= la #&& (ha #<= hb) + let open Expr.Infix in + lb <= la && ha <= hb let size (a, b) = Expr.Infix.( - ) b a let point_strictly_inside x (l, h) = - let open Formula.Infix in - l #< x #&& (x #< h) + let open Expr.Infix in + l < x && x < h let split_at (l, h) x = ((l, x), (x, h)) let lvars (a, b) = SS.union (Expr.lvars a) (Expr.lvars b) @@ -259,8 +259,8 @@ module Node = struct let chunk = SVal.leak_chunk sv in let chunk_size = Expr.int (Chunk.size chunk) in let zeros_can_be_converted_to_same_chunk = - let open Formula.Infix in - (Expr.imod size_right chunk_size) #== Expr.zero_i + let open Expr.Infix in + Expr.imod size_right chunk_size == Expr.zero_i in if%ent zeros_can_be_converted_to_same_chunk then let+ zero_array = @@ -287,8 +287,8 @@ module Node = struct let chunk = SVal.leak_chunk sv in let chunk_size = Expr.int (Chunk.size chunk) in let zeros_can_be_converted_to_same_chunk = - let open Formula.Infix in - (Expr.imod size_left chunk_size) #== Expr.zero_i + let open Expr.Infix in + Expr.imod size_left chunk_size == Expr.zero_i in if%ent zeros_can_be_converted_to_same_chunk then let+ zero_array = @@ -317,8 +317,8 @@ module Node = struct let chunk = SVArr.leak_chunk arr in let chunk_size = Expr.int (Chunk.size chunk) in let zeros_can_be_converted_to_same_chunk = - let open Formula.Infix in - (Expr.imod size_left chunk_size) #== Expr.zero_i + let open Expr.Infix in + Expr.imod size_left chunk_size == Expr.zero_i in if%ent zeros_can_be_converted_to_same_chunk then let+ zero_array = @@ -338,8 +338,8 @@ module Node = struct let chunk = SVArr.leak_chunk arr in let chunk_size = Expr.int (Chunk.size chunk) in let zeros_can_be_converted_to_same_chunk = - let open Formula.Infix in - (Expr.imod size_right chunk_size) #== Expr.zero_i + let open Expr.Infix in + Expr.imod size_right chunk_size == Expr.zero_i in if%ent zeros_can_be_converted_to_same_chunk then let+ zero_array = @@ -563,14 +563,14 @@ module Tree = struct let rec split ~range t : (Node.t * t * t) Delayed.t = (* this function splits a tree and returns the node in the given range *) (* We're assuming that range is inside old_span *) - let open Formula.Infix in + let open Expr.Infix in let open Delayed.Syntax in let old_span = t.span in let ol, oh = old_span in let nl, nh = range in if%sat log_string "ol #== nl"; - ol #== nl + ol == nl then let at = nh in let+ left_node, right_node = Node.split ~span:old_span ~at t.node in @@ -581,7 +581,7 @@ module Tree = struct else if%sat log_string "oh #== nh"; - oh #== nh + oh == nh then let at = nl in let+ left_node, right_node = Node.split ~span:old_span ~at t.node in @@ -602,12 +602,12 @@ module Tree = struct (node, left, right) let extend_if_needed t range = - let open Formula.Infix in + let open Expr.Infix in let open Delayed.Syntax in let rl, rh = range in let sl, sh = t.span in let* t_with_left = - if%sat rl #< sl then + if%sat rl < sl then let new_left_tree = make ~node:(NotOwned Totally) ~span:(rl, sl) () in let children = (new_left_tree, t) in Delayed.return @@ -616,7 +616,7 @@ module Tree = struct in let sl, _ = t_with_left.span in let* result = - if%sat rh #> sh then + if%sat rh > sh then let new_right_tree = make ~node:(NotOwned Totally) ~span:(sh, rh) () in let children = (t_with_left, new_right_tree) in Delayed.return @@ -1117,7 +1117,7 @@ let get_root = function let is_in_bounds range bounds = match bounds with - | None -> Formula.True + | None -> Expr.true_ | Some bounds -> Range.is_inside range bounds let get_perm_at t ofs = @@ -1139,10 +1139,10 @@ let get_perm_at t ofs = let weak_valid_pointer (t : t) (ofs : Expr.t) : (bool, err) DR.t = let is_sure_false bounds ofs = - let open Formula.Infix in + let open Expr.Infix in match bounds with - | None -> Formula.False - | Some (low, high) -> ofs #< low #|| (ofs #> high) + | None -> Expr.false_ + | Some (low, high) -> ofs < low || ofs > high in match t with | Freed -> DR.ok false @@ -1360,8 +1360,8 @@ let _check_valid_alignment chunk ofs = let al = Chunk.align chunk in let al_expr = Expr.int al in let divides x y = - let open Formula.Infix in - Expr.(y #== (int 0)) #|| ((Expr.imod y x) #== (Expr.int 0)) + let open Expr.Infix in + y == Expr.int 0 || Expr.imod y x == Expr.int 0 in if%sat divides al_expr ofs then DR.ok () else DR.error (InvalidAlignment { offset = ofs; alignment = al }) diff --git a/Gillian-C2/lib/memory_model/SVal.ml b/Gillian-C2/lib/memory_model/SVal.ml index b239278a..04612eca 100644 --- a/Gillian-C2/lib/memory_model/SVal.ml +++ b/Gillian-C2/lib/memory_model/SVal.ml @@ -21,18 +21,18 @@ module SVal = struct { v with value } let unsign_int ~bit_size (e : Expr.t) = - let open Formula.Infix in - if%sat Expr.zero_i #<= e then Delayed.return e + let open Expr.Infix in + if%sat Expr.zero_i <= e then Delayed.return e else let two_power_size = Z.(one lsl bit_size) in let open Expr.Infix in Delayed.return (e + Expr.int_z two_power_size) let sign_int ~bit_size (e : Expr.t) = - let open Formula.Infix in + let open Expr.Infix in let two_power_size = Z.(one lsl bit_size) in let imax = Expr.int_z Z.((two_power_size asr 1) - one) in - if%sat e #<= imax then Delayed.return e + if%sat e <= imax then Delayed.return e else let open Expr.Infix in Delayed.return (e - Expr.int_z two_power_size) @@ -77,8 +77,8 @@ module SVal = struct let learned = match Chunk.bounds chunk with | Some (low, high) -> - let open Formula.Infix in - [ lvar_e #>= (Expr.int_z low); lvar_e #<= (Expr.int_z high) ] + let open Expr.Infix in + [ lvar_e >= Expr.int_z low; lvar_e <= Expr.int_z high ] | None -> [] in (learned_types, learned) @@ -132,8 +132,8 @@ module SVal = struct let all_bytes = List.map (fun lv -> - let open Formula.Infix in - Expr.zero_i #<= lv #&& (lv #<= (Expr.int 255))) + let open Expr.Infix in + Expr.zero_i <= lv && lv <= Expr.int 255) exprs in (* We take the bytes from small to big *) @@ -148,8 +148,8 @@ module SVal = struct (Z.shift_left i 8, res_expr)) (Z.one, Expr.zero_i) exprs in - let open Formula.Infix in - unsigned_value #== (snd total_sum_bytes) + let open Expr.Infix in + unsigned_value == snd total_sum_bytes in let learned = add_to_sval :: all_bytes in let result = @@ -270,7 +270,6 @@ module SVArray = struct else None let make_zeros ~chunk ~size : t Delayed.t = - let open Formula.Infix in let return ?learned ?learned_types values = Delayed.return ?learned ?learned_types { chunk; values } in @@ -286,21 +285,20 @@ module SVArray = struct in return values | _ -> + let open Expr.Infix in Logging.verbose (fun fmt -> fmt "Zeros pf: not as concrete: %a" Expr.pp size); let values_var = LVar.alloc () in let values = Expr.LVar values_var in - let is_zero e = e #== (Expr.int 0) in + let is_zero e = e == Expr.int 0 in let i = LVar.alloc () in let i_e = Expr.LVar i in let zero = Expr.zero_i in let learned_types = [ (values_var, Type.ListType) ] in - let correct_length = (Expr.list_length values) #== size in + let correct_length = Expr.list_length values == size in let all_zero = - forall - [ (i, Some IntType) ] - zero #<= i_e #&& (i_e #< size) - #=> (is_zero (Expr.list_nth_e values i_e)) + forall [ (i, Some IntType) ] zero <= i_e + && i_e < size ==> is_zero (Expr.list_nth_e values i_e) in return ~learned:[ correct_length; all_zero ] ~learned_types values @@ -466,8 +464,8 @@ module SVArray = struct let split_at_byte ~at arr : (t * t) Delayed.t = let chunk_size = Expr.int (Chunk.size arr.chunk) in let can_keep_chunk = - let open Formula.Infix in - (Expr.imod at chunk_size) #== Expr.zero_i + let open Expr.Infix in + Expr.imod at chunk_size == Expr.zero_i in if%ent can_keep_chunk then Delayed.return (split_at_offset ~at:Expr.Infix.(at / chunk_size) arr) From 3e948ee7fae12861f7d51e1de61ef81ea5281b71 Mon Sep 17 00:00:00 2001 From: N1ark Date: Wed, 25 Dec 2024 12:51:58 +0100 Subject: [PATCH 35/54] Update Gillian-JS --- Gillian-JS/lib/Compiler/JS2JSIL_Compiler.ml | 54 ++++++------ Gillian-JS/lib/Compiler/JSIL2GIL.ml | 35 ++------ Gillian-JS/lib/Compiler/JSIL_PostParser.ml | 43 +++++----- Gillian-JS/lib/JSIL/Asrt.ml | 10 +-- Gillian-JS/lib/JSIL/LCmd.ml | 13 ++- Gillian-JS/lib/JSIL/Pred.ml | 7 +- Gillian-JS/lib/JSLogic/JSAsrt.ml | 61 ++++++------- Gillian-JS/lib/JSLogic/JSLCmd.ml | 1 - Gillian-JS/lib/JSLogic/JSPred.ml | 4 +- Gillian-JS/lib/JSLogic/JSSpec.ml | 16 ++-- Gillian-JS/lib/Parsing/Javert_Parser.mly | 42 ++++----- Gillian-JS/lib/Semantics/JSILSMemory.ml | 94 +++++++++++---------- Gillian-JS/lib/Semantics/SFVL.ml | 4 +- Gillian-JS/lib/Semantics/SFVL.mli | 2 +- Gillian-JS/lib/Semantics/SHeap.ml | 6 +- 15 files changed, 191 insertions(+), 201 deletions(-) diff --git a/Gillian-JS/lib/Compiler/JS2JSIL_Compiler.ml b/Gillian-JS/lib/Compiler/JS2JSIL_Compiler.ml index 63f739d7..a3311476 100644 --- a/Gillian-JS/lib/Compiler/JS2JSIL_Compiler.ml +++ b/Gillian-JS/lib/Compiler/JS2JSIL_Compiler.ml @@ -84,7 +84,7 @@ let prefix_lcmds let is_list_type x = BinOp (UnOp (TypeOf, x), Equal, lit_typ ListType) let is_vref x = BinOp (rtype x, Equal, lit_refv) let is_oref x = BinOp (rtype x, Equal, lit_refo) -let is_ref x = BinOp (is_vref x, BOr, is_oref x) +let is_ref x = BinOp (is_vref x, Or, is_oref x) let rec get_break_lab loop_list lab = match loop_list with @@ -206,14 +206,14 @@ let non_writable_ref_test x = let right_e = BinOp ( BinOp (field x, Equal, lit_str "eval"), - BOr, + Or, BinOp (field x, Equal, Lit (String "arguments")) ) in - BinOp (left_e, BAnd, right_e) + BinOp (left_e, And, right_e) let make_unresolvable_ref_test x = BinOp - (BinOp (base x, Equal, Lit Null), BOr, BinOp (base x, Equal, Lit Undefined)) + (BinOp (base x, Equal, Lit Null), Or, BinOp (base x, Equal, Lit Undefined)) let make_get_value_call x err = (* x_v := getValue (x) with err *) @@ -437,7 +437,7 @@ let translate_binop_plus x1 x2 x1_v x2_v err = let goto_guard_right = BinOp (UnOp (TypeOf, PVar x2_p), Equal, Lit (Type StringType)) in - let goto_guard = BinOp (goto_guard_left, BOr, goto_guard_right) in + let goto_guard = BinOp (goto_guard_left, Or, goto_guard_right) in let cmd_goto = LGuardedGoto (goto_guard, then_lab, else_lab) in (* then: x1_s := i__toString (x1_p) with err *) @@ -598,7 +598,7 @@ let translate_binop_equality _ _ x1_v x2_v non_strict non_negated err = | false -> let x_r2 = fresh_var () in (* x_r2 := (not x_r1) *) - ([ (None, LBasic (Assignment (x_r2, UnOp (UNot, PVar x_r1)))) ], x_r2) + ([ (None, LBasic (Assignment (x_r2, UnOp (Not, PVar x_r1)))) ], x_r2) in let new_cmds = [ (None, cmd_ass_xr1) ] @ cmd_ass_xr2 in @@ -1699,7 +1699,7 @@ let rec translate_expr tr_ctx e : let next1 = fresh_next_label () in let goto_guard_expr = UnOp - ( UNot, + ( Not, BinOp (UnOp (TypeOf, PVar x_f_val), Equal, Lit (Type ObjectType)) ) in let cmd_goto_is_obj = @@ -2075,7 +2075,7 @@ let rec translate_expr tr_ctx e : let le = SSubst.subst_in_expr subst ~partial:true e' in let asrt = - match Formula.lift_logic_expr le with + match Expr.as_boolean_expr le with | Some (asrt_b, _) -> asrt_b | _ -> raise @@ -2119,7 +2119,7 @@ let rec translate_expr tr_ctx e : let le = SSubst.subst_in_expr subst ~partial:true e' in let asrt = - match Formula.lift_logic_expr le with + match Expr.as_boolean_expr le with | Some (asrt_b, _) -> asrt_b | _ -> raise @@ -2143,16 +2143,22 @@ let rec translate_expr tr_ctx e : let cmd1 = (metadata, None, LLogic (LCmd.FreshSVar x_v)) in let x_v = PVar x_v in let cmd2 = - (metadata, None, LLogic (LCmd.Assume (Not (Eq (x_v, Lit Empty))))) + ( metadata, + None, + LLogic (LCmd.Assume (UnOp (Not, BinOp (x_v, Equal, Lit Empty)))) ) in let cmd3 = - (metadata, None, LLogic (LCmd.Assume (Not (Eq (x_v, Lit Nono))))) + ( metadata, + None, + LLogic (LCmd.Assume (UnOp (Not, BinOp (x_v, Equal, Lit Nono)))) ) in let cmd4 = ( metadata, None, LLogic - (LCmd.Assume (Not (Eq (UnOp (TypeOf, x_v), Lit (Type ListType))))) + (LCmd.Assume + (UnOp + (Not, BinOp (UnOp (TypeOf, x_v), Equal, Lit (Type ListType))))) ) in ([ cmd1; cmd2; cmd3; cmd4 ], x_v, []) @@ -2274,7 +2280,7 @@ let rec translate_expr tr_ctx e : let next1 = fresh_next_label () in let goto_guard_expr = UnOp - ( UNot, + ( Not, BinOp (UnOp (TypeOf, PVar x_f_val), Equal, Lit (Type ObjectType)) ) in let cmd_goto_is_obj = @@ -2934,7 +2940,7 @@ let rec translate_expr tr_ctx e : (* x_r := (not x_b) *) let x_r = fresh_var () in - let cmd_xr_ass = LBasic (Assignment (x_r, UnOp (UNot, PVar x_b))) in + let cmd_xr_ass = LBasic (Assignment (x_r, UnOp (Not, PVar x_b))) in let cmds = annotate_first_cmd @@ -3265,7 +3271,7 @@ let rec translate_expr tr_ctx e : tr_ctx.tr_err_lab in let x_r2 = fresh_var () in - let new_cmd = LBasic (Assignment (x_r2, UnOp (UNot, PVar x_r1))) in + let new_cmd = LBasic (Assignment (x_r2, UnOp (Not, PVar x_r1))) in let cmds = annotate_first_cmd (cmds1 @@ -3310,7 +3316,7 @@ let rec translate_expr tr_ctx e : tr_ctx.tr_err_lab in let x_r2 = fresh_var () in - let new_cmd = LBasic (Assignment (x_r2, UnOp (UNot, PVar x_r1))) in + let new_cmd = LBasic (Assignment (x_r2, UnOp (Not, PVar x_r1))) in let cmds = annotate_first_cmd (cmds1 @@ -5325,7 +5331,7 @@ and translate_statement tr_ctx e = let next1 = fresh_next_label () in let next2 = fresh_next_label () in let expr_goto_guard = BinOp (PVar x_ret_2, Equal, Lit Empty) in - let expr_goto_guard = UnOp (UNot, expr_goto_guard) in + let expr_goto_guard = UnOp (Not, expr_goto_guard) in let cmd_goto_empty_test = LGuardedGoto (expr_goto_guard, next1, next2) in (* x_ret_3 := PHI(x_ret_1, x_ret_2) *) @@ -5473,7 +5479,7 @@ and translate_statement tr_ctx e = let next1 = fresh_next_label () in let next2 = fresh_next_label () in let expr_goto_guard = BinOp (PVar x_ret_2, Equal, Lit Empty) in - let expr_goto_guard = UnOp (UNot, expr_goto_guard) in + let expr_goto_guard = UnOp (Not, expr_goto_guard) in let cmd_goto_empty_test = LGuardedGoto (expr_goto_guard, next1, next2) in (* x_ret_3 := PHI(x_ret_1, x_ret_2) *) @@ -5627,7 +5633,7 @@ and translate_statement tr_ctx e = let expr_goto_guard = BinOp ( BinOp (PVar x2_v, Equal, Lit Null), - BOr, + Or, BinOp (PVar x2_v, Equal, Lit Undefined) ) in let cmd_goto_null_undef = LGuardedGoto (expr_goto_guard, next6, next0) in @@ -5717,7 +5723,7 @@ and translate_statement tr_ctx e = (* goto [ not (x_ret_2 = empty) ] next2 next3 *) let expr_goto_guard = BinOp (PVar x_ret_2, Equal, Lit Empty) in - let expr_goto_guard = UnOp (UNot, expr_goto_guard) in + let expr_goto_guard = UnOp (Not, expr_goto_guard) in let cmd_goto_xret2 = LGuardedGoto (expr_goto_guard, next2, next3) in (* x_ret_3 := PHI(x_ret_1, x_ret_2) *) @@ -5952,7 +5958,7 @@ and translate_statement tr_ctx e = let next1 = fresh_next_label () in let next2 = fresh_next_label () in let expr_goto_guard = BinOp (PVar x_ret_2, Equal, Lit Empty) in - let expr_goto_guard = UnOp (UNot, expr_goto_guard) in + let expr_goto_guard = UnOp (Not, expr_goto_guard) in let cmd_goto_empty_test = LGuardedGoto (expr_goto_guard, next1, next2) in (* next2: x_ret_3 := PHI(x_ret_1, x_ret_2) *) @@ -6323,7 +6329,7 @@ and translate_statement tr_ctx e = (* goto [ not x_prev_found ] next1 next2 *) let cmd_goto_1 = - LGuardedGoto (UnOp (UNot, PVar x_prev_found), next1, next2) + LGuardedGoto (UnOp (Not, PVar x_prev_found), next1, next2) in (* x1_v := getValue (x1) with err *) @@ -6428,7 +6434,7 @@ and translate_statement tr_ctx e = (* goto [ not (x_found_b) ] next end_switch *) let next = fresh_next_label () in let cmd_goto = - LGuardedGoto (UnOp (UNot, PVar x_found_b), next, end_switch) + LGuardedGoto (UnOp (Not, PVar x_found_b), next, end_switch) in let cmds_def = add_initial_label cmds_def next metadata in @@ -6800,7 +6806,7 @@ let generate_main e strictness spec : EProc.t = make_final_cmd errs ctx.tr_err_lab Names.return_variable origin_loc in let lab_err_cmd = annotate_cmd LReturnError None in - let global_err_asrt = annotate_cmd (LLogic (LCmd.Assert False)) None in + let global_err_asrt = annotate_cmd (LLogic (LCmd.Assert Expr.false_)) None in let err_cmds = if !Javert_utils.Js_config.cosette then [ cmd_err_phi_node; global_err_asrt; lab_err_cmd ] diff --git a/Gillian-JS/lib/Compiler/JSIL2GIL.ml b/Gillian-JS/lib/Compiler/JSIL2GIL.ml index 0e7bbe44..31ccae3c 100644 --- a/Gillian-JS/lib/Compiler/JSIL2GIL.ml +++ b/Gillian-JS/lib/Compiler/JSIL2GIL.ml @@ -34,7 +34,7 @@ let fresh_var, reset_var = fresh_sth "gvar_aux_" let resource_error args = if Utils.Exec_mode.is_biabduction_exec !Config.current_exec_mode then - GCmd.Logic (GLCmd.Assume False) + GCmd.Logic (GLCmd.Assume Expr.false_) else Fail (JSILNames.resourceError, args) let reset_generators () = @@ -74,26 +74,6 @@ let rec jsil2gil_expr (e : Expr.t) : Expr.t = ESet es | _ -> e -let rec jsil2gil_formula (f : Gil.Formula.t) : Gil.Formula.t = - let ff = jsil2gil_formula in - let fe = jsil2gil_expr in - match f with - | True | False -> f - | Not f -> Not (ff f) - | And (f1, f2) -> And (ff f1, ff f2) - | Or (f1, f2) -> Or (ff f1, ff f2) - | Impl (f1, f2) -> Impl (ff f1, ff f2) - | Eq (e1, e2) -> Eq (fe e1, fe e2) - | FLess (e1, e2) -> FLess (fe e1, fe e2) - | FLessEq (e1, e2) -> FLessEq (fe e1, fe e2) - | ILess (e1, e2) -> ILess (fe e1, fe e2) - | ILessEq (e1, e2) -> ILessEq (fe e1, fe e2) - | StrLess (e1, e2) -> StrLess (fe e1, fe e2) - | SetMem (e1, e2) -> SetMem (fe e1, fe e2) - | SetSub (e1, e2) -> SetSub (fe e1, fe e2) - | ForAll (qts, f) -> ForAll (qts, ff f) - | IsInt e -> IsInt (fe e) - let rec jsil2gil_asrt (a : Asrt.t) : GAsrt.t = let f = jsil2gil_asrt in let fe = jsil2gil_expr in @@ -106,7 +86,7 @@ let rec jsil2gil_asrt (a : Asrt.t) : GAsrt.t = | EmptyFields (e1, e2) -> [ Asrt_utils.empty_fields ~loc:(fe e1) ~domain:(fe e2) ] | Pred (pn, es) -> [ Pred (pn, List.map fe es) ] - | Pure f -> [ Pure (jsil2gil_formula f) ] + | Pure f -> [ Pure (jsil2gil_expr f) ] | Types vts -> [ Types (List.map (fun (v, t) -> (fe v, t)) vts) ] let jsil2gil_slcmd (slcmd : SLCmd.t) : GSLCmd.t = @@ -122,13 +102,12 @@ let rec jsil2gil_lcmd (lcmd : LCmd.t) : GLCmd.t = let f = jsil2gil_lcmd in let fs = List.map f in let fe = jsil2gil_expr in - let ff = jsil2gil_formula in match lcmd with | If (e, lcmds1, lcmds2) -> If (fe e, fs lcmds1, fs lcmds2) - | Branch f -> Branch (ff f) + | Branch f -> Branch (fe f) | Macro (x, es) -> Macro (x, List.map fe es) - | Assert f -> Assert (ff f) - | Assume f -> Assume (ff f) + | Assert f -> Assert (fe f) + | Assume f -> Assume (fe f) | AssumeType (x, t) -> AssumeType (fe x, t) | FreshSVar x -> FreshSVar x | SL slcmd -> SL (jsil2gil_slcmd slcmd) @@ -189,7 +168,7 @@ let jsil2gil_pred (pred : Pred.t) : GPred.t = pred_ins = pred.ins; pred_definitions = List.map (fun (info, asrt) -> (info, jsil2gil_asrt asrt)) pred.definitions; - pred_facts = List.map jsil2gil_formula pred.facts; + pred_facts = List.map jsil2gil_expr pred.facts; pred_guard = None; (* TODO: Support for predicates with tokens *) pred_pure = pred.pure; @@ -383,7 +362,7 @@ let jsil2core (lab : string option) (cmd : LabCmd.t) : let aux3 = fresh_var () in let e = Expr.UnOp - (UNot, BinOp (BinOp (PVar aux3, LstNth, Expr.int 2), Equal, Lit Nono)) + (Not, BinOp (BinOp (PVar aux3, LstNth, Expr.int 2), Equal, Lit Nono)) in let cmd1 : string GCmd.t = Assignment (aux1, fe e1) in let cmd2 : string GCmd.t = Assignment (aux2, fe e2) in diff --git a/Gillian-JS/lib/Compiler/JSIL_PostParser.ml b/Gillian-JS/lib/Compiler/JSIL_PostParser.ml index 0fbcca3a..f253e3f8 100644 --- a/Gillian-JS/lib/Compiler/JSIL_PostParser.ml +++ b/Gillian-JS/lib/Compiler/JSIL_PostParser.ml @@ -86,10 +86,12 @@ let make_sc (vis_list : string list) : Expr.t list = List.map expr_from_fid chopped_vis_list let asrts_js_val (x_val : Expr.t) : Asrt.t list = - let asrt_empty : Asrt.t = Pure (Not (Eq (x_val, Lit Empty))) in - let asrt_none : Asrt.t = Pure (Not (Eq (x_val, Lit Nono))) in + let asrt_empty : Asrt.t = + Pure (UnOp (Not, BinOp (x_val, Equal, Lit Empty))) + in + let asrt_none : Asrt.t = Pure (UnOp (Not, BinOp (x_val, Equal, Lit Nono))) in let asrt_list : Asrt.t = - Pure (Not (Eq (UnOp (TypeOf, x_val), Lit (Type ListType)))) + Pure (UnOp (Not, BinOp (UnOp (TypeOf, x_val), Equal, Lit (Type ListType)))) in [ asrt_empty; asrt_none; asrt_list ] @@ -114,21 +116,22 @@ let var_assertion (fid : string) (x : string) (x_val : Expr.t) : Asrt.t = let make_this_assertion () : Asrt.t = let var_this = JS2JSIL_Helpers.var_this in - let f1 : Formula.t = - Not (Eq (UnOp (TypeOf, LVar "#this"), Lit (Type ListType))) + let f1 : Expr.t = + UnOp (Not, BinOp (UnOp (TypeOf, LVar "#this"), Equal, Lit (Type ListType))) in - let f2 : Formula.t = - Not (Eq (UnOp (TypeOf, LVar "#this"), Lit (Type NumberType))) + let f2 : Expr.t = + UnOp (Not, BinOp (UnOp (TypeOf, LVar "#this"), Equal, Lit (Type NumberType))) in - let f3 : Formula.t = - Not (Eq (UnOp (TypeOf, LVar "#this"), Lit (Type StringType))) + let f3 : Expr.t = + UnOp (Not, BinOp (UnOp (TypeOf, LVar "#this"), Equal, Lit (Type StringType))) in - let f4 : Formula.t = - Not (Eq (UnOp (TypeOf, LVar "#this"), Lit (Type BooleanType))) + let f4 : Expr.t = + UnOp + (Not, BinOp (UnOp (TypeOf, LVar "#this"), Equal, Lit (Type BooleanType))) in - let f5 : Formula.t = Not (Eq (LVar "#this", Lit Empty)) in - let f6 : Formula.t = Eq (LVar "#this", PVar var_this) in - Asrt.Pure (Formula.conjunct [ f1; f2; f3; f4; f5; f6 ]) + let f5 : Expr.t = UnOp (Not, BinOp (LVar "#this", Equal, Lit Empty)) in + let f6 : Expr.t = BinOp (LVar "#this", Equal, PVar var_this) in + Asrt.Pure (Expr.conjunct [ f1; f2; f3; f4; f5; f6 ]) let scope_info_to_assertion (eprog : EProg.t) @@ -144,7 +147,7 @@ let scope_info_to_assertion in let a_schain = - Asrt.Pure (Eq (PVar JS2JSIL_Helpers.var_scope, EList sc_bindings)) + Asrt.Pure (BinOp (PVar JS2JSIL_Helpers.var_scope, Equal, EList sc_bindings)) in let glob_constraints = @@ -152,7 +155,9 @@ let scope_info_to_assertion | _ :: les -> List.map (fun le -> - Asrt.Pure (Not (Eq (le, Lit (Loc JS2JSIL_Helpers.locGlobName))))) + Asrt.Pure + (UnOp + (Not, BinOp (le, Equal, Lit (Loc JS2JSIL_Helpers.locGlobName))))) les | _ -> [] in @@ -190,7 +195,7 @@ let scope_info_to_assertion else if SS.mem x args then let x_val : Expr.t = LVar (Names.make_svar_name x) in let asrts_x = asrts_js_val x_val in - Pure (Eq (PVar x, x_val)) :: asrts_x + Pure (BinOp (PVar x, Equal, x_val)) :: asrts_x else [] in asrts @ new_asrts) @@ -219,7 +224,7 @@ let create_pre_scope_pred in let a_schain = - Asrt.Pure (Eq (PVar JS2JSIL_Helpers.var_scope, EList sc_bindings)) + Asrt.Pure (BinOp (PVar JS2JSIL_Helpers.var_scope, Equal, EList sc_bindings)) in let fid_vis_tbl = Jslogic.JSLogicCommon.get_scope_table cc_tbl fid in @@ -425,7 +430,7 @@ let bi_post_parse_cmd (cmd : Annot.Basic.t * string option * LabCmd.t) : None ) in let test = LabCmd.LGuardedGoto (PVar x_r, lab_t, lab_f) in - let t_cmd = LabCmd.LLogic (Assert False) in + let t_cmd = LabCmd.LLogic (Assert Expr.false_) in let f_cmd = LabCmd.LReturnError in [ diff --git a/Gillian-JS/lib/JSIL/Asrt.ml b/Gillian-JS/lib/JSIL/Asrt.ml index aacd543a..9957c82b 100644 --- a/Gillian-JS/lib/JSIL/Asrt.ml +++ b/Gillian-JS/lib/JSIL/Asrt.ml @@ -9,15 +9,15 @@ type t = | MetaData of Expr.t * Expr.t (** MetaData *) | Pred of string * Expr.t list (** Predicates *) | EmptyFields of Expr.t * Expr.t (** emptyFields assertion *) - | Pure of Formula.t (** Pure formula *) + | Pure of Expr.t (** Pure formula *) | Types of (Expr.t * Type.t) list (** Typing assertion *) let compare x y = let cmp = Stdlib.compare in match (x, y) with - | Pure (Eq (PVar x, _)), Pure (Eq (PVar y, _)) -> cmp x y - | Pure (Eq (PVar _, _)), _ -> -1 - | _, Pure (Eq (PVar _, _)) -> 1 + | Pure (BinOp (PVar x, Equal, _)), Pure (BinOp (PVar y, Equal, _)) -> cmp x y + | Pure (BinOp (PVar _, Equal, _)), _ -> -1 + | _, Pure (BinOp (PVar _, Equal, _)) -> 1 | PointsTo _, PointsTo _ -> cmp x y | PointsTo _, _ -> -1 | _, PointsTo _ -> 1 @@ -66,7 +66,7 @@ let rec pp fmt (a : t) : unit = (* MetaData (e1, e2) *) | MetaData (e1, e2) -> Fmt.pf fmt "MetaData (%a, %a)" Expr.pp e1 Expr.pp e2 (* Pure *) - | Pure f -> Formula.pp fmt f + | Pure f -> Expr.pp fmt f let full_pp = pp let pp_list = Fmt.list ~sep:(Fmt.any " ") pp diff --git a/Gillian-JS/lib/JSIL/LCmd.ml b/Gillian-JS/lib/JSIL/LCmd.ml index 71b65d28..041842b9 100644 --- a/Gillian-JS/lib/JSIL/LCmd.ml +++ b/Gillian-JS/lib/JSIL/LCmd.ml @@ -1,6 +1,5 @@ module SSubst = Gillian.Symbolic.Subst module Expr = Gillian.Gil_syntax.Expr -module Formula = Gillian.Gil_syntax.Formula module Type = Gillian.Gil_syntax.Type (***************************************************************) @@ -11,10 +10,10 @@ module Type = Gillian.Gil_syntax.Type (** {b JSIL logic commands}. *) type t = | If of Expr.t * t list * t list (** If-then-else *) - | Branch of Formula.t (** branching on a FO formual *) + | Branch of Expr.t (** branching on a FO formual *) | Macro of string * Expr.t list (** Macro *) - | Assert of Formula.t (** Assert *) - | Assume of Formula.t (** Assume *) + | Assert of Expr.t (** Assert *) + | Assume of Expr.t (** Assume *) | AssumeType of Expr.t * Type.t (** Assume Type *) | FreshSVar of string | SL of SLCmd.t @@ -31,10 +30,10 @@ let rec pp fmt lcmd = else Fmt.pf fmt "if (%a) @[then {@\n%a@]@\n}" Expr.pp le pp_list then_lcmds - | Branch fo -> Fmt.pf fmt "branch (%a)" Formula.pp fo + | Branch fo -> Fmt.pf fmt "branch (%a)" Expr.pp fo | Macro (name, lparams) -> Fmt.pf fmt "%s(%a)" name pp_params lparams - | Assert a -> Fmt.pf fmt "assert (%a)" Formula.pp a - | Assume a -> Fmt.pf fmt "assume (%a)" Formula.pp a + | Assert a -> Fmt.pf fmt "assert (%a)" Expr.pp a + | Assume a -> Fmt.pf fmt "assume (%a)" Expr.pp a | FreshSVar x -> Fmt.pf fmt "%s := fresh_svar()" x | SL sl_cmd -> SLCmd.pp fmt sl_cmd | AssumeType (e, t) -> diff --git a/Gillian-JS/lib/JSIL/Pred.ml b/Gillian-JS/lib/JSIL/Pred.ml index f4cfce34..148d08d9 100644 --- a/Gillian-JS/lib/JSIL/Pred.ml +++ b/Gillian-JS/lib/JSIL/Pred.ml @@ -2,7 +2,6 @@ module SSubst = Gillian.Symbolic.Subst module L = Logging module Type = Gillian.Gil_syntax.Type module Expr = Gillian.Gil_syntax.Expr -module Formula = Gillian.Gil_syntax.Formula (** {b JSIL logic predicate}. *) type t = { @@ -12,7 +11,7 @@ type t = { ins : int list; (** Ins *) definitions : ((string * string list) option * Asrt.t) list; (** Predicate definitions *) - facts : Formula.t list; (** Facts about the predicate *) + facts : Expr.t list; (** Facts about the predicate *) pure : bool; (** Is the predicate pure *) abstract : bool; (** Is the predicate abstract *) nounfold : bool; (** Should the predicate be unfolded? *) @@ -68,9 +67,7 @@ let pp fmt pred = let pp_facts fmt = function | [] -> () | facts -> - Fmt.pf fmt "@\nfacts: %a;" - Fmt.(list ~sep:(any " and ") Formula.pp) - facts + Fmt.pf fmt "@\nfacts: %a;" Fmt.(list ~sep:(any " and ") Expr.pp) facts in Fmt.pf fmt "@[%a%a%apred %s(%a):@\n%a;%a@]" pp_abstract pred.abstract pp_pure pred.pure pp_nounfold pred.nounfold name diff --git a/Gillian-JS/lib/JSLogic/JSAsrt.ml b/Gillian-JS/lib/JSLogic/JSAsrt.ml index 7b64d420..d9472143 100644 --- a/Gillian-JS/lib/JSLogic/JSAsrt.ml +++ b/Gillian-JS/lib/JSLogic/JSAsrt.ml @@ -38,27 +38,27 @@ let star (asrts : t list) : t = if not (a = Emp) then if ac = Emp then a else Star (a, ac) else ac) Emp asrts -let rec js2jsil_pure (scope_le : Expr.t option) (a : pt) : Formula.t = +let rec js2jsil_pure (scope_le : Expr.t option) (a : pt) : Expr.t = let f = js2jsil_pure scope_le in let fe = JSExpr.js2jsil scope_le in (* What about metadata here? Or extensibility *) match a with - | And (a1, a2) -> Formula.And (f a1, f a2) - | Or (a1, a2) -> Formula.Or (f a1, f a2) - | Not a -> Formula.Not (f a) - | True -> Formula.True - | False -> Formula.False - | Eq (le1, le2) -> Formula.Eq (fe le1, fe le2) - | Less (le1, le2) -> Formula.FLess (fe le1, fe le2) - | LessEq (le1, le2) -> Formula.FLessEq (fe le1, fe le2) - | StrLess (le1, le2) -> Formula.StrLess (fe le1, fe le2) + | And (a1, a2) -> Expr.BinOp (f a1, And, f a2) + | Or (a1, a2) -> BinOp (f a1, Or, f a2) + | Not a -> UnOp (Not, f a) + | True -> Expr.true_ + | False -> Expr.false_ + | Eq (le1, le2) -> BinOp (fe le1, Equal, fe le2) + | Less (le1, le2) -> BinOp (fe le1, FLessThan, fe le2) + | LessEq (le1, le2) -> BinOp (fe le1, FLessThanEqual, fe le2) + | StrLess (le1, le2) -> BinOp (fe le1, StrLess, fe le2) | ForAll (s, a) -> let new_binders = List.map (fun (x, t) -> (x, Some t)) s in - Formula.ForAll (new_binders, f a) - | SetMem (le1, le2) -> Formula.SetMem (fe le1, fe le2) - | SetSub (le1, le2) -> Formula.SetSub (fe le1, fe le2) - | IsInt e -> Formula.IsInt (fe e) + ForAll (new_binders, f a) + | SetMem (le1, le2) -> BinOp (fe le1, SetMem, fe le2) + | SetSub (le1, le2) -> BinOp (fe le1, SetSub, fe le2) + | IsInt e -> UnOp (IsInt, fe e) let rec js2jsil (cur_fid : string option) @@ -96,12 +96,14 @@ let rec js2jsil let len = List.length (get_vis_list vis_tbl fid) in let a_len = Asrt.Pure - (Eq (Lit (Num (float_of_int (len - 1))), UnOp (LstLen, fe sch))) + (BinOp + (Lit (Num (float_of_int (len - 1))), Equal, UnOp (LstLen, fe sch))) in let a_lg = Asrt.Pure - (Eq + (BinOp ( Lit (Loc locGlobName), + Equal, Expr.BinOp (fe sch, LstNth, Expr.Lit (Num (float_of_int 0))) )) in let a_pred = @@ -135,21 +137,17 @@ let rec js2jsil | Some i -> let le_x = fe le_x in let le_er = - Expr.BinOp (fe le_sc, LstNth, Expr.Lit (Num (float_of_int i))) + Expr.BinOp (fe le_sc, LstNth, Lit (Num (float_of_int i))) in let not_lg = Asrt.Pure - (Formula.Not (Formula.Eq (le_er, Expr.Lit (Loc locGlobName)))) + (UnOp (Not, BinOp (le_er, Equal, Lit (Loc locGlobName)))) in let not_none = - Asrt.Pure (Formula.Not (Formula.Eq (le_x, Expr.Lit Nono))) + Asrt.Pure (UnOp (Not, BinOp (le_x, Equal, Lit Nono))) in Asrt.star - [ - not_lg; - not_none; - Asrt.PointsTo (le_er, Expr.Lit (String x), le_x); - ] + [ not_lg; not_none; Asrt.PointsTo (le_er, Lit (String x), le_x) ] in (* add_extra_scope_chain_info fid le_sc a'*) a' @@ -165,9 +163,10 @@ let rec js2jsil let le_sc2' = fe le_sc2 in let f j = Asrt.Pure - (Formula.Eq - ( Expr.BinOp (le_sc1', LstNth, Expr.Lit (Num (float_of_int j))), - Expr.BinOp (le_sc2', LstNth, Lit (Num (float_of_int j))) )) + (BinOp + ( BinOp (le_sc1', LstNth, Lit (Num (float_of_int j))), + Equal, + BinOp (le_sc2', LstNth, Lit (Num (float_of_int j))) )) in Asrt.star (List.map f is) (* Tr(scope(x: le_x)) ::= Tr(scope(x: le_x, sc, fid)) *) @@ -256,7 +255,7 @@ let rec js2jsil let scope_chain_list = vislist_2_les vis_list (List.length vis_list - 1) in - Asrt.Pure (Formula.Eq (fe le, EList scope_chain_list)) + Asrt.Pure (BinOp (fe le, Equal, EList scope_chain_list)) let errors_assertion () = Asrt.Star @@ -277,11 +276,13 @@ let js2jsil_tactic in (* x__scope == {{ #x1, ..., #xn }} *) - let a'' = Asrt.Pure (Eq (Expr.PVar scope_var, Expr.EList scope_chain_list)) in + let a'' = + Asrt.Pure (BinOp (Expr.PVar scope_var, Equal, Expr.EList scope_chain_list)) + in (* x__this == #this *) let a_this = - Asrt.Pure (Eq (Expr.PVar var_this, Expr.LVar this_logic_var_name)) + Asrt.Pure (BinOp (Expr.PVar var_this, Equal, Expr.LVar this_logic_var_name)) in Asrt.star [ a'; a''; a_this ] diff --git a/Gillian-JS/lib/JSLogic/JSLCmd.ml b/Gillian-JS/lib/JSLogic/JSLCmd.ml index 3b8fb31f..4ec5aa59 100644 --- a/Gillian-JS/lib/JSLogic/JSLCmd.ml +++ b/Gillian-JS/lib/JSLogic/JSLCmd.ml @@ -1,6 +1,5 @@ open JSLogicCommon open Jsil_syntax -module Formula = Gillian.Gil_syntax.Formula type t = | Fold of JSAsrt.t * (string * (string * JSExpr.t) list) option diff --git a/Gillian-JS/lib/JSLogic/JSPred.ml b/Gillian-JS/lib/JSLogic/JSPred.ml index 056c8dc5..29777907 100644 --- a/Gillian-JS/lib/JSLogic/JSPred.ml +++ b/Gillian-JS/lib/JSLogic/JSPred.ml @@ -1,6 +1,6 @@ open JSLogicCommon module Type = Gillian.Gil_syntax.Type -module Formula = Gillian.Gil_syntax.Formula +module Expr = Gillian.Gil_syntax.Expr module Pred = Jsil_syntax.Pred type t = { @@ -9,7 +9,7 @@ type t = { params : (string * Type.t option) list; ins : int list; definitions : ((string * string list) option * JSAsrt.t) list; - facts : Formula.t list; + facts : Expr.t list; abstract : bool; pure : bool; nounfold : bool; diff --git a/Gillian-JS/lib/JSLogic/JSSpec.ml b/Gillian-JS/lib/JSLogic/JSSpec.ml index 0b096485..e7ecfa47 100644 --- a/Gillian-JS/lib/JSLogic/JSSpec.ml +++ b/Gillian-JS/lib/JSLogic/JSSpec.ml @@ -42,31 +42,33 @@ let js2jsil_st (* x \in params -> (! (x == empty)) *) let params_not_empty : Asrt.t list = List.map - (fun x -> Asrt.Pure (Not (Eq (Expr.PVar x, Expr.Lit Empty)))) + (fun x -> Asrt.Pure (UnOp (Not, BinOp (PVar x, Equal, Lit Empty)))) params in let params_not_none : Asrt.t list = - List.map (fun x -> Asrt.Pure (Not (Eq (Expr.PVar x, Expr.Lit Nono)))) params + List.map + (fun x -> Asrt.Pure (UnOp (Not, BinOp (PVar x, Equal, Lit Nono)))) + params in let params_and_lists : Asrt.t list = List.map (fun x -> - let fml : Formula.t = - Eq (Expr.UnOp (TypeOf, Expr.PVar x), Expr.Lit (Type ListType)) + let fml : Expr.t = + BinOp (UnOp (TypeOf, PVar x), Equal, Lit (Type ListType)) in - let fml : Formula.t = if x = var_scope then fml else Not fml in + let fml = if x = var_scope then fml else UnOp (Not, fml) in Asrt.Pure fml) params in (* x__this == #this *) let a_this = - Asrt.Pure (Eq (Expr.PVar var_this, Expr.LVar this_logic_var_name)) + Asrt.Pure (BinOp (Expr.PVar var_this, Equal, Expr.LVar this_logic_var_name)) in (* x__scope == {{ #x1, ..., #xn }} *) let a_scope = - Asrt.Pure (Eq (Expr.PVar var_scope, Expr.EList scope_chain_list)) + Asrt.Pure (BinOp (Expr.PVar var_scope, Equal, Expr.EList scope_chain_list)) in (* let er_sc_list = (match scope_chain_list with | [] -> [] | _ -> List.tl scope_chain_list) in diff --git a/Gillian-JS/lib/Parsing/Javert_Parser.mly b/Gillian-JS/lib/Parsing/Javert_Parser.mly index 85156e5a..72fa5282 100644 --- a/Gillian-JS/lib/Parsing/Javert_Parser.mly +++ b/Gillian-JS/lib/Parsing/Javert_Parser.mly @@ -269,7 +269,7 @@ let normalised_lvar_r = Str.regexp "##NORMALISED_LVAR" %type binop_target %type nop_target %type expr_target -%type pure_assertion_target +%type pure_assertion_target %type jsil_main_target %start jsil_main_target @@ -338,7 +338,7 @@ lit_target: unop_target: - | NOT { UnOp.UNot } + | NOT { UnOp.Not } | BITWISENOT { UnOp.BitwiseNot } | M_ISNAN { UnOp.M_isNaN } | M_ABS { UnOp.M_abs } @@ -375,14 +375,14 @@ binop_target: | EQUAL { BinOp.Equal } | LESSTHAN { BinOp.FLessThan } | LESSTHANEQUAL { BinOp.FLessThanEqual } - | LESSTHANSTRING { BinOp.SLessThan } + | LESSTHANSTRING { BinOp.StrLess } | PLUS { BinOp.FPlus } | MINUS { BinOp.FMinus } | TIMES { BinOp.FTimes } | DIV { BinOp.FDiv } | MOD { BinOp.FMod } - | AND { BinOp.BAnd } - | OR { BinOp.BOr } + | AND { BinOp.And } + | OR { BinOp.Or } | BITWISEAND { BinOp.BitwiseAndF } | BITWISEOR { BinOp.BitwiseOrF } | BITWISEXOR { BinOp.BitwiseXorF } @@ -393,8 +393,8 @@ binop_target: | M_POW { BinOp.M_pow } | STRCAT { BinOp.StrCat } | SETDIFF { BinOp.SetDiff } - | SETMEM { BinOp.BSetMem } - | SETSUB { BinOp.BSetSub } + | SETMEM { BinOp.SetMem } + | SETSUB { BinOp.SetSub } nop_target: | SETUNION { NOp.SetUnion } @@ -448,27 +448,27 @@ lvar_type_target: pure_assertion_target: | left_ass=pure_assertion_target; LAND; right_ass=pure_assertion_target - { Formula.And (left_ass, right_ass) } + { Expr.BinOp (left_ass, And, right_ass) } | left_ass=pure_assertion_target; LOR; right_ass=pure_assertion_target - { Formula.Or (left_ass, right_ass) } - | LNOT; ass=pure_assertion_target { Formula.Not (ass) } - | ISINT; expr=expr_target { Formula.IsInt (expr) } - | LTRUE { Formula.True } - | LFALSE { Formula.False } + { Expr.BinOp (left_ass, Or, right_ass) } + | LNOT; ass=pure_assertion_target { Expr.UnOp (Not, ass) } + | ISINT; expr=expr_target { Expr.UnOp (IsInt, expr) } + | LTRUE { Expr.Lit (Bool true) } + | LFALSE { Expr.Lit (Bool false) } | left_expr=expr_target; LEQUAL; right_expr=expr_target - { Formula.Eq (left_expr, right_expr) } + { Expr.BinOp (left_expr, Equal, right_expr) } | left_expr=expr_target; LLESSTHAN; right_expr=expr_target - { Formula.FLess (left_expr, right_expr) } + { Expr.BinOp (left_expr, FLessThan, right_expr) } | left_expr=expr_target; LLESSTHANEQUAL; right_expr=expr_target - { Formula.FLessEq (left_expr, right_expr) } + { Expr.BinOp (left_expr, FLessThanEqual, right_expr) } | left_expr=expr_target; LLESSTHANSTRING; right_expr=expr_target - { Formula.StrLess (left_expr, right_expr) } + { Expr.BinOp (left_expr, StrLess, right_expr) } | left_expr=expr_target; LSETMEM; right_expr=expr_target - { Formula.SetMem (left_expr, right_expr) } + { Expr.BinOp (left_expr, SetMem, right_expr) } | left_expr=expr_target; LSETSUB; right_expr=expr_target - { Formula.SetSub (left_expr, right_expr) } + { Expr.BinOp (left_expr, SetSub, right_expr) } | LFORALL; vars = separated_nonempty_list(COMMA, lvar_type_target); DOT; ass = pure_assertion_target - { Formula.ForAll (vars, ass) } + { Expr.ForAll (vars, ass) } | delimited(LBRACE, pure_assertion_target, RBRACE) { $1 } @@ -1274,4 +1274,4 @@ top_level_js_pre_target: lab = option(js_sspec_lab_target); a=js_assertion_target; EOF { (lab, a) } top_level_expr_target: - e = expr_target; EOF { e } \ No newline at end of file + e = expr_target; EOF { e } diff --git a/Gillian-JS/lib/Semantics/JSILSMemory.ml b/Gillian-JS/lib/Semantics/JSILSMemory.ml index b2929db3..746b33cf 100644 --- a/Gillian-JS/lib/Semantics/JSILSMemory.ml +++ b/Gillian-JS/lib/Semantics/JSILSMemory.ml @@ -28,13 +28,13 @@ module M = struct | FLoc of vt | FCell of vt * vt | FMetadata of vt - | FPure of Formula.t + | FPure of Expr.t [@@deriving yojson, show] - type err_t = vt list * i_fix_t list list * Formula.t [@@deriving yojson, show] + type err_t = vt list * i_fix_t list list * Expr.t [@@deriving yojson, show] type action_ret = - ( (t * vt list * Formula.t list * (string * Type.t) list) list, + ( (t * vt list * Expr.t list * (string * Type.t) list) list, err_t list ) result @@ -45,9 +45,9 @@ module M = struct | FCell (loc, prop) -> pf ft "@[MIFCell(%a, %a)@]" SVal.pp loc SVal.pp prop | FMetadata loc -> pf ft "@[MIFMetadata(%a)@]" SVal.pp loc - | FPure f -> pf ft "@[MIFPure(%a)@]" Formula.pp f + | FPure f -> pf ft "@[MIFPure(%a)@]" Expr.pp f - let get_failing_constraint (err : err_t) : Formula.t = + let get_failing_constraint (err : err_t) : Expr.t = let _, _, f = err in f @@ -55,7 +55,7 @@ module M = struct let open Fmt in let vs, fixes, f = err in let pp_fixes ft fix = pf ft "[%a]" (list ~sep:comma pp_i_fix) fix in - pf ft "@[<[%a], %a, %a>@]" (list ~sep:comma SVal.pp) vs Formula.pp f + pf ft "@[<[%a], %a, %a>@]" (list ~sep:comma SVal.pp) vs Expr.pp f (list ~sep:semi pp_fixes) fixes let get_recovery_tactic (heap : t) (err : err_t) = @@ -100,7 +100,7 @@ module M = struct let substitution_in_place ~pfs:_ ~gamma:_ (subst : st) (heap : t) = SHeap.substitution_in_place subst heap; - [ (heap, Formula.Set.empty, []) ] + [ (heap, Expr.Set.empty, []) ] let pp fmt (heap : t) : unit = SHeap.pp fmt heap let pp_by_need locs fmt heap = SHeap.pp_by_need locs fmt heap @@ -114,7 +114,7 @@ module M = struct Gillian.Logic.FOSolver.resolve_loc_name ~pfs ~gamma let fresh_loc ?(loc : vt option) (pfs : PFS.t) (gamma : Type_env.t) : - string * vt * Formula.t list = + string * vt * Expr.t list = match loc with | Some loc -> ( let loc_name = get_loc_name pfs gamma loc in @@ -125,7 +125,7 @@ module M = struct else (loc_name, Expr.Lit (Loc loc_name), []) | None -> let al = ALoc.alloc () in - (al, ALoc al, [ Formula.Eq (ALoc al, loc) ])) + (al, ALoc al, [ Expr.BinOp (ALoc al, Equal, loc) ])) | None -> let al = ALoc.alloc () in (al, ALoc al, []) @@ -145,7 +145,7 @@ module M = struct | Some (ALoc loc) -> (loc, ALoc loc) | Some (LVar v) -> let loc_name = ALoc.alloc () in - PFS.extend pfs (Eq (LVar v, ALoc loc_name)); + PFS.extend pfs (BinOp (LVar v, Equal, ALoc loc_name)); (loc_name, ALoc loc_name) | Some le -> raise @@ -188,19 +188,23 @@ module M = struct let loc = Expr.loc_from_loc_name loc_name in (* failing_constraint *) let ff = - Formula.conjunct - (List.map (fun prop' -> Formula.Not (Eq (prop, prop'))) props) + Expr.conjunct + (List.map + (fun prop' -> Expr.UnOp (Not, BinOp (prop, Equal, prop'))) + props) in let fixes_exist_props : i_fix_t list list = - List.map (fun prop' -> [ FPure (Formula.Eq (prop, prop')) ]) props + List.map + (fun prop' -> [ FPure (Expr.BinOp (prop, Equal, prop')) ]) + props in let fix_new_property : i_fix_t list = [ FCell (loc, prop); FPure ff ] in match dom with | Some dom -> - let ff' : Formula.t = SetMem (prop, dom) in - let ff'' : Formula.t = And (ff, ff') in + let ff' : Expr.t = BinOp (prop, SetMem, dom) in + let ff'' : Expr.t = BinOp (ff, And, ff') in let fix_new_property' : i_fix_t list = FPure ff' :: fix_new_property in @@ -233,7 +237,9 @@ module M = struct ] | _, Some (ffn, ffv) -> Ok [ (heap, [ loc; ffn; ffv ], [], []) ] | Some dom, None -> - let a_set_inclusion : Formula.t = Not (SetMem (prop, dom)) in + let a_set_inclusion : Expr.t = + UnOp (Not, BinOp (prop, SetMem, dom)) + in if FOSolver.check_entailment Containers.SS.empty pfs [ a_set_inclusion ] gamma @@ -250,17 +256,18 @@ module M = struct Ok [ (heap, [ loc; prop; Lit Nono ], [], []) ]) else let f_names : Expr.t list = SFVL.field_names fv_list in - let full_knowledge : Formula.t = Eq (dom, ESet f_names) in + let full_knowledge : Expr.t = + BinOp (dom, Equal, ESet f_names) + in if FOSolver.check_entailment Containers.SS.empty pfs [ full_knowledge ] gamma then ( L.verbose (fun m -> m "GET CELL will branch\n"); - let rets : (t * vt list * Formula.t list * 'a) option list - = + let rets : (t * vt list * Expr.t list * 'a) option list = List.map (fun (f_name, f_value) -> - let new_f : Formula.t = Eq (f_name, prop) in + let new_f : Expr.t = BinOp (f_name, Equal, prop) in let sat = FOSolver.check_satisfiability ~time:"JS getCell branch: heap" @@ -284,7 +291,9 @@ module M = struct in (* I need the case in which the prop does not exist *) - let new_f : Formula.t = Not (SetMem (prop, dom)) in + let new_f : Expr.t = + UnOp (Not, BinOp (prop, SetMem, dom)) + in let sat = FOSolver.check_satisfiability ~time:"JS getCell branch: domain" @@ -303,15 +312,13 @@ module M = struct make_gc_error loc_name prop (SFVL.field_names fv_list) (Some dom); ])) - ~none: - (Error [ ([], [ [ FLoc loc; FCell (loc, prop) ] ], Formula.False) ]) + ~none:(Error [ ([], [ [ FLoc loc; FCell (loc, prop) ] ], Expr.false_) ]) (SHeap.get heap loc_name) in let result = Option.fold ~some:get_cell_from_loc - ~none: - (Error [ ([], [ [ FLoc loc; FCell (loc, prop) ] ], Formula.False) ]) + ~none:(Error [ ([], [ [ FLoc loc; FCell (loc, prop) ] ], Expr.false_) ]) loc_name in result @@ -354,7 +361,7 @@ module M = struct let make_gm_error (loc_name : string) : err_t = let loc = Expr.loc_from_loc_name loc_name in - ([ loc ], [ [ FMetadata loc ] ], False) + ([ loc ], [ [ FMetadata loc ] ], Expr.false_) in let f loc_name = @@ -372,8 +379,7 @@ module M = struct in Option.fold ~some:f - ~none: - (Error [ ([ loc ], [ [ FLoc loc; FMetadata loc ] ], Formula.False) ]) + ~none:(Error [ ([ loc ], [ [ FLoc loc; FMetadata loc ] ], Expr.false_) ]) loc_name let set_metadata @@ -391,7 +397,7 @@ module M = struct SHeap.set heap loc_name fv_list dom (Some mtdt) | Some ((fv_list, dom), Some omet) -> if omet <> Option.get (SVal.from_expr (Lit Null)) then - PFS.extend pfs (Eq (mtdt, omet)) + PFS.extend pfs (BinOp (mtdt, Equal, omet)) else SHeap.set heap loc_name fv_list dom (Some mtdt)); L.tmi (fun m -> m "Done setting metadata."); Ok [ (heap, [], new_pfs, []) ] @@ -461,9 +467,7 @@ module M = struct | _ -> raise (Failure "DEATH. get_partial_domain. dom_diff")) in let result = - Option.fold ~some:f - ~none:(Error [ ([ loc ], [], Formula.False) ]) - loc_name + Option.fold ~some:f ~none:(Error [ ([ loc ], [], Expr.false_) ]) loc_name in result @@ -481,7 +485,7 @@ module M = struct raise (Failure "DEATH. TODO. get_full_domain. missing domain") | Some ((fv_list, Some dom), _) -> let props = SFVL.field_names fv_list in - let a_set_equality : Formula.t = Eq (dom, ESet props) in + let a_set_equality : Expr.t = BinOp (dom, Equal, ESet props) in let solver_ret = FOSolver.check_entailment Containers.SS.empty pfs [ a_set_equality ] gamma @@ -495,9 +499,7 @@ module M = struct in let result = - Option.fold ~some:f - ~none:(Error [ ([ loc ], [], Formula.False) ]) - loc_name + Option.fold ~some:f ~none:(Error [ ([ loc ], [], Expr.false_) ]) loc_name in result @@ -589,7 +591,7 @@ module M = struct else if a_id = JSILNames.aProps then JSILNames.delProps else raise (Failure "DEATH. ga_to_setter") - let mem_constraints (state : t) : Formula.t list = SHeap.wf_assertions state + let mem_constraints (state : t) : Expr.t list = SHeap.wf_assertions state let is_overlapping_asrt (a : string) : bool = if a = JSILNames.aMetadata then true else false @@ -605,7 +607,7 @@ module M = struct however it only seemed to add the binding without creating any state, so did it really "do" anything? Bi-abduction is broken for Gillian-JS anyways. *) let al = ALoc.alloc () in - [ [ Asrt.Pure (Eq (ALoc al, v)) ] ] + [ [ Asrt.Pure (BinOp (ALoc al, Equal, v)) ] ] | FCell (l, p) -> ( let none_fix () = [ Asrt.CorePred (JSILNames.aCell, [ l; p ], [ Lit Nono ]) ] @@ -614,10 +616,10 @@ module M = struct let some_fix () = let vvar = LVar.alloc () in let v : vt = LVar vvar in - let asrt_empty : Formula.t = Not (Eq (v, Lit Empty)) in - let asrt_none : Formula.t = Not (Eq (v, Lit Nono)) in - let asrt_list : Formula.t = - Not (Eq (UnOp (TypeOf, v), Lit (Type ListType))) + let asrt_empty : Expr.t = UnOp (Not, BinOp (v, Equal, Lit Empty)) in + let asrt_none : Expr.t = UnOp (Not, BinOp (v, Equal, Lit Nono)) in + let asrt_list : Expr.t = + UnOp (Not, BinOp (UnOp (TypeOf, v), Equal, Lit (Type ListType))) in let descriptor : Expr.t = EList @@ -648,7 +650,7 @@ module M = struct let mloc = Expr.ALoc al in [ [ - Asrt.Pure (Eq (ALoc al, l)); + Asrt.Pure (BinOp (ALoc al, Equal, l)); Asrt.CorePred (JSILNames.aMetadata, [ l ], [ mloc ]); Asrt.CorePred (JSILNames.aMetadata, [ mloc ], [ Lit Null ]); Asrt.CorePred @@ -673,13 +675,13 @@ module M = struct | FLoc v -> (* Get a fresh location *) let al = ALoc.alloc () in - [ [ Asrt.Pure (Eq (ALoc al, v)) ] ] + [ [ Asrt.Pure (BinOp (ALoc al, Equal, v)) ] ] | FCell (l, p) -> (* Fresh variable to denote the property value *) let vvar = LVar.alloc () in let v : vt = LVar vvar in (* Value is not none - we always bi-abduce presence *) - let not_none : Formula.t = Not (Eq (v, Lit Nono)) in + let not_none : Expr.t = UnOp (Not, BinOp (v, Equal, Lit Nono)) in [ [ Asrt.CorePred (JSILNames.aCell, [ l; p ], [ v ]); Asrt.Pure not_none; @@ -689,7 +691,7 @@ module M = struct (* Fresh variable to denote the property value *) let vvar = LVar.alloc () in let v : vt = LVar vvar in - let not_none : Formula.t = Not (Eq (v, Lit Nono)) in + let not_none : Expr.t = UnOp (Not, BinOp (v, Equal, Lit Nono)) in [ [ Asrt.CorePred (JSILNames.aMetadata, [ l ], [ v ]); diff --git a/Gillian-JS/lib/Semantics/SFVL.ml b/Gillian-JS/lib/Semantics/SFVL.ml index 9231e48d..ae5aa6ef 100644 --- a/Gillian-JS/lib/Semantics/SFVL.ml +++ b/Gillian-JS/lib/Semantics/SFVL.ml @@ -105,8 +105,8 @@ let selective_substitution (subst : SSubst.t) (partial : bool) (fv_list : t) : t (* Correctness of field-value lists *) let is_well_formed (_ : t) : bool = true -let wf_assertions (sfvl : t) : Formula.t list = +let wf_assertions (sfvl : t) : Expr.t list = let props = field_names sfvl in let props' = List_utils.cross_product props props (fun x y -> (x, y)) in let props' = List.filter (fun (x, y) -> x <> y) props' in - List.map (fun (x, y) : Formula.t -> Not (Eq (x, y))) props' + List.map (fun (x, y) : Expr.t -> UnOp (Not, BinOp (x, Equal, y))) props' diff --git a/Gillian-JS/lib/Semantics/SFVL.mli b/Gillian-JS/lib/Semantics/SFVL.mli index 3427ed05..02341521 100644 --- a/Gillian-JS/lib/Semantics/SFVL.mli +++ b/Gillian-JS/lib/Semantics/SFVL.mli @@ -27,5 +27,5 @@ val assertions : Expr.t -> t -> Asrt.t val substitution : Subst.t -> bool -> t -> t val selective_substitution : Subst.t -> bool -> t -> t val is_well_formed : t -> bool -val wf_assertions : t -> Formula.t list +val wf_assertions : t -> Expr.t list val to_list : t -> (field_name * field_value) list diff --git a/Gillian-JS/lib/Semantics/SHeap.ml b/Gillian-JS/lib/Semantics/SHeap.ml index f4a9885a..a160b310 100644 --- a/Gillian-JS/lib/Semantics/SHeap.ml +++ b/Gillian-JS/lib/Semantics/SHeap.ml @@ -361,7 +361,7 @@ let assertions (heap : t) : Asrt.t = to_list heap |> List.concat_map assertions_of_object |> List.sort Asrt.compare -let wf_assertions_of_obj (heap : t) (loc : string) : Formula.t list = +let wf_assertions_of_obj (heap : t) (loc : string) : Expr.t list = let cfvl = Option.value ~default:SFVL.empty (Hashtbl.find_opt heap.cfvl loc) in @@ -372,9 +372,9 @@ let wf_assertions_of_obj (heap : t) (loc : string) : Formula.t list = let spps = SFVL.field_names sfvl in let props = List_utils.cross_product spps (cpps @ spps) (fun x y -> (x, y)) in let props = List.filter (fun (x, y) -> x <> y) props in - List.map (fun (x, y) : Formula.t -> Not (Eq (x, y))) props + List.map (fun (x, y) : Expr.t -> UnOp (Not, BinOp (x, Equal, y))) props -let wf_assertions (heap : t) : Formula.t list = +let wf_assertions (heap : t) : Expr.t list = let domain = domain heap in SS.fold (fun loc ac -> wf_assertions_of_obj heap loc @ ac) domain [] From 0c2bb48b59efb120bbe10ba9ed85789afcbdfbdf Mon Sep 17 00:00:00 2001 From: N1ark Date: Wed, 25 Dec 2024 12:52:16 +0100 Subject: [PATCH 36/54] Update WISL --- wisl/lib/ParserAndCompiler/wisl2Gil.ml | 50 +++++++++++--------------- wisl/lib/semantics/wislSHeap.ml | 12 +++---- wisl/lib/semantics/wislSHeap.mli | 2 +- wisl/lib/semantics/wislSMemory.ml | 16 +++------ 4 files changed, 32 insertions(+), 48 deletions(-) diff --git a/wisl/lib/ParserAndCompiler/wisl2Gil.ml b/wisl/lib/ParserAndCompiler/wisl2Gil.ml index 7f7ab1e4..cb04c256 100644 --- a/wisl/lib/ParserAndCompiler/wisl2Gil.ml +++ b/wisl/lib/ParserAndCompiler/wisl2Gil.ml @@ -40,8 +40,8 @@ let compile_binop b = | TIMES -> BinOp.ITimes | DIV -> BinOp.IDiv | MOD -> BinOp.IMod - | AND -> BinOp.BAnd - | OR -> BinOp.BOr + | AND -> BinOp.And + | OR -> BinOp.Or | LSTNTH -> BinOp.LstNth (* operators that do not exist in gil are compiled separately *) | _ -> @@ -51,7 +51,7 @@ let compile_binop b = let compile_unop u = WUnOp.( match u with - | NOT -> UnOp.UNot + | NOT -> UnOp.Not | LEN -> UnOp.LstLen | HEAD -> UnOp.Car | TAIL -> UnOp.Cdr @@ -183,7 +183,7 @@ let rec compile_lexpr ?(fname = "main") (lexpr : WLExpr.t) : let gvars1, asrtl1, comp_expr1 = compile_lexpr e1 in let gvars2, asrtl2, comp_expr2 = compile_lexpr e2 in let expr = - Expr.UnOp (UnOp.UNot, Expr.BinOp (comp_expr1, BinOp.Equal, comp_expr2)) + Expr.UnOp (UnOp.Not, Expr.BinOp (comp_expr1, BinOp.Equal, comp_expr2)) in (gvars1 @ gvars2, asrtl1 @ asrtl2, expr) | LBinOp (e1, b, e2) when is_internal_pred b -> @@ -237,57 +237,53 @@ let rec compile_lexpr ?(fname = "main") (lexpr : WLExpr.t) : (List.concat gvars, List.concat asrtsl, Expr.ESet comp_exprs)) (* TODO: compile_lformula should return also the list of created existentials *) -let rec compile_lformula ?(fname = "main") formula : Asrt.t * Formula.t = +let rec compile_lformula ?(fname = "main") formula : Asrt.t * Expr.t = let gen_str = Generators.gen_str fname in let compile_lformula = compile_lformula ~fname in let compile_lexpr = compile_lexpr ~fname in WLFormula.( match get formula with - | LTrue -> ([], Formula.True) - | LFalse -> ([], Formula.False) + | LTrue -> ([], Expr.true_) + | LFalse -> ([], Expr.false_) | LNot lf -> let a1, c1 = compile_lformula lf in - (a1, Formula.Not c1) + (a1, UnOp (Not, c1)) | LAnd (lf1, lf2) -> let a1, c1 = compile_lformula lf1 in let a2, c2 = compile_lformula lf2 in - (a1 @ a2, Formula.And (c1, c2)) + (a1 @ a2, BinOp (c1, And, c2)) | LOr (lf1, lf2) -> let a1, c1 = compile_lformula lf1 in let a2, c2 = compile_lformula lf2 in - (a1 @ a2, Formula.Or (c1, c2)) + (a1 @ a2, BinOp (c1, Or, c2)) | LEq (le1, le2) -> let _, a1, c1 = compile_lexpr le1 in let _, a2, c2 = compile_lexpr le2 in - (a1 @ a2, Formula.Eq (c1, c2)) + (a1 @ a2, BinOp (c1, Equal, c2)) | LLess (le1, le2) -> let _, a1, c1 = compile_lexpr le1 in let _, a2, c2 = compile_lexpr le2 in let expr_l_var_out = Expr.LVar (gen_str sgvar) in let pred = Asrt.Pred (internal_pred_lt, [ c1; c2; expr_l_var_out ]) in - ( a1 @ a2 @ [ pred ], - Formula.Eq (expr_l_var_out, Expr.Lit (Literal.Bool true)) ) + (a1 @ a2 @ [ pred ], BinOp (expr_l_var_out, Equal, Expr.true_)) | LGreater (le1, le2) -> let _, a1, c1 = compile_lexpr le1 in let _, a2, c2 = compile_lexpr le2 in let expr_l_var_out = Expr.LVar (gen_str sgvar) in let pred = Asrt.Pred (internal_pred_gt, [ c1; c2; expr_l_var_out ]) in - ( a1 @ a2 @ [ pred ], - Formula.Eq (expr_l_var_out, Expr.Lit (Literal.Bool true)) ) + (a1 @ a2 @ [ pred ], BinOp (expr_l_var_out, Equal, Expr.true_)) | LLessEq (le1, le2) -> let _, a1, c1 = compile_lexpr le1 in let _, a2, c2 = compile_lexpr le2 in let expr_l_var_out = Expr.LVar (gen_str sgvar) in let pred = Asrt.Pred (internal_pred_leq, [ c1; c2; expr_l_var_out ]) in - ( a1 @ a2 @ [ pred ], - Formula.Eq (expr_l_var_out, Expr.Lit (Literal.Bool true)) ) + (a1 @ a2 @ [ pred ], BinOp (expr_l_var_out, Equal, Expr.true_)) | LGreaterEq (le1, le2) -> let _, a1, c1 = compile_lexpr le1 in let _, a2, c2 = compile_lexpr le2 in let expr_l_var_out = Expr.LVar (gen_str sgvar) in let pred = Asrt.Pred (internal_pred_geq, [ c1; c2; expr_l_var_out ]) in - ( a1 @ a2 @ [ pred ], - Formula.Eq (expr_l_var_out, Expr.Lit (Literal.Bool true)) )) + (a1 @ a2 @ [ pred ], BinOp (expr_l_var_out, Equal, Expr.true_))) (* compile_lassert returns the compiled assertion + the list of generated existentials *) let rec compile_lassert ?(fname = "main") asser : string list * Asrt.t = @@ -340,7 +336,7 @@ let rec compile_lassert ?(fname = "main") asser : string list * Asrt.t = | Lit (Int _) -> [] | _ -> [ (expr_offset, Type.IntType) ]) :: Asrt.Pure - (Formula.Eq (e1, Expr.EList [ Expr.LVar loc; expr_offset ])) + (BinOp (e1, Equal, Expr.EList [ Expr.LVar loc; expr_offset ])) :: la1, (loc, offset), expr_offset ) @@ -891,10 +887,7 @@ let rec compile_stmt_list ?(fname = "main") ?(is_loop_prefix = false) stmtl = WAnnot.make ~origin_id:sid ~origin_loc:(CodeLoc.to_location sloc) () in let cmdle, comp_e = compile_expr e in - let cmd = - let formula = Formula.Eq (comp_e, Expr.bool true) in - Cmd.Logic (LCmd.Assert formula) - in + let cmd = Cmd.Logic (Assert (BinOp (comp_e, Equal, Expr.true_))) in let comp_rest, new_functions = compile_list rest in (cmdle @ [ (annot, None, cmd) ] @ comp_rest, new_functions) | { snode = Assume e; sid; sloc } :: rest -> @@ -902,10 +895,7 @@ let rec compile_stmt_list ?(fname = "main") ?(is_loop_prefix = false) stmtl = WAnnot.make ~origin_id:sid ~origin_loc:(CodeLoc.to_location sloc) () in let cmdle, comp_e = compile_expr e in - let cmd = - let formula = Formula.Eq (comp_e, Expr.bool true) in - Cmd.Logic (LCmd.Assume formula) - in + let cmd = Cmd.Logic (Assume (BinOp (comp_e, Equal, Expr.true_))) in let comp_rest, new_functions = compile_list rest in (cmdle @ [ (annot, None, cmd) ] @ comp_rest, new_functions) | { snode = AssumeType (e, t); sid; sloc } :: rest -> @@ -914,7 +904,7 @@ let rec compile_stmt_list ?(fname = "main") ?(is_loop_prefix = false) stmtl = WAnnot.make ~origin_id:sid ~origin_loc:(CodeLoc.to_location sloc) () in let cmdle, comp_e = compile_expr e in - let cmd = Cmd.Logic (LCmd.AssumeType (comp_e, typ)) in + let cmd = Cmd.Logic (AssumeType (comp_e, typ)) in let comp_rest, new_functions = compile_list rest in (cmdle @ [ (annot, None, cmd) ] @ comp_rest, new_functions) @@ -1165,7 +1155,7 @@ let compile ~filepath WProg.{ context; predicates; lemmas } = (fun name proc -> let pre = List.map - (fun var -> Asrt.Pure (Eq (Expr.PVar var, Expr.LVar ("#" ^ var)))) + (fun var -> Asrt.Pure (BinOp (PVar var, Equal, LVar ("#" ^ var)))) proc.Proc.proc_params in diff --git a/wisl/lib/semantics/wislSHeap.ml b/wisl/lib/semantics/wislSHeap.ml index d8df4aff..5801c0e8 100644 --- a/wisl/lib/semantics/wislSHeap.ml +++ b/wisl/lib/semantics/wislSHeap.ml @@ -146,8 +146,8 @@ let get_cell ~pfs ~gamma heap loc ofs = | None -> false | Some n -> let n = Expr.int n in - let open Formula.Infix in - Solver.sat ~matching:false ~pfs ~gamma n #<= ofs + let open Expr.Infix in + Solver.sat ~matching:false ~pfs ~gamma (n <= ofs) in if maybe_out_of_bound then Error (OutOfBounds (bound, loc, ofs)) else @@ -176,8 +176,8 @@ let set_cell ~pfs ~gamma heap loc_name ofs v = | None -> false | Some n -> let n = Expr.int n in - let open Formula.Infix in - Solver.sat ~matching:false ~pfs ~gamma n #<= ofs + let open Expr.Infix in + Solver.sat ~matching:false ~pfs ~gamma (n <= ofs) in if maybe_out_of_bound then Error (UseAfterFree loc_name) else @@ -265,7 +265,7 @@ let merge_loc (heap : t) new_loc old_loc : unit = Hashtbl.remove heap old_loc) let substitution_in_place subst heap : - (t * Formula.Set.t * (string * Type.t) list) list = + (t * Expr.Set.t * (string * Type.t) list) list = (* First we replace in the offset and values using fvl *) let () = Hashtbl.iter @@ -297,7 +297,7 @@ let substitution_in_place subst heap : ((WPrettyUtils.to_str Expr.pp) new_loc))) in merge_loc heap new_loc_str aloc); - [ (heap, Formula.Set.empty, []) ] + [ (heap, Expr.Set.empty, []) ] let assertions heap = Hashtbl.fold (fun loc block acc -> Block.assertions ~loc block @ acc) heap [] diff --git a/wisl/lib/semantics/wislSHeap.mli b/wisl/lib/semantics/wislSHeap.mli index 6fad4af1..b24a341b 100644 --- a/wisl/lib/semantics/wislSHeap.mli +++ b/wisl/lib/semantics/wislSHeap.mli @@ -52,7 +52,7 @@ val substitution_in_place : Gillian.Symbolic.Subst.t -> t -> (t - * Gillian.Gil_syntax.Formula.Set.t + * Gillian.Gil_syntax.Expr.Set.t * (string * Gillian.Gil_syntax.Type.t) list) list diff --git a/wisl/lib/semantics/wislSMemory.ml b/wisl/lib/semantics/wislSMemory.ml index 9fc830a2..4e39e94c 100644 --- a/wisl/lib/semantics/wislSMemory.ml +++ b/wisl/lib/semantics/wislSMemory.ml @@ -8,15 +8,9 @@ module SS = Gillian.Utils.Containers.SS type init_data = unit type vt = Values.t -type st = Subst.t type err_t = WislSHeap.err [@@deriving yojson, show] type t = WislSHeap.t [@@deriving yojson] -type action_ret = - ( (t * vt list * Formula.t list * (string * Type.t) list) list, - err_t list ) - result - let init () = WislSHeap.init () let get_init_data _ = () let clear _ = WislSHeap.init () @@ -45,7 +39,7 @@ let set_cell heap pfs gamma (loc : vt) (offset : vt) (value : vt) = else (loc_name, []) | None -> let al = ALoc.alloc () in - (al, [ Formula.Eq (Expr.ALoc al, loc) ]) + (al, [ Expr.BinOp (Expr.ALoc al, Equal, loc) ]) in match WislSHeap.set_cell ~pfs ~gamma heap loc_name offset value with | Error e -> Error [ e ] @@ -83,7 +77,7 @@ let set_bound heap pfs gamma (loc : vt) (bound : int) = else (loc_name, []) | None -> let al = ALoc.alloc () in - (al, [ Formula.Eq (Expr.ALoc al, loc) ]) + (al, [ Expr.BinOp (ALoc al, Equal, loc) ]) in match WislSHeap.set_bound heap loc_name bound with | Error e -> Error [ e ] @@ -120,7 +114,7 @@ let set_freed heap pfs gamma (loc : vt) = else (loc_name, []) | None -> let al = ALoc.alloc () in - (al, [ Formula.Eq (Expr.ALoc al, loc) ]) + (al, [ Expr.BinOp (ALoc al, Equal, loc) ]) in let () = WislSHeap.set_freed heap loc_name in Ok [ (heap, [], new_pfs, []) ] @@ -315,13 +309,13 @@ let get_fixes (err : err_t) = | InvalidLocation loc -> let new_loc = ALoc.alloc () in let new_expr = Expr.ALoc new_loc in - [ [ Asrt.Pure (Eq (new_expr, loc)) ] ] + [ [ Asrt.Pure (BinOp (new_expr, Equal, loc)) ] ] | _ -> [] let can_fix = function | WislSHeap.InvalidLocation _ | MissingResource _ -> true | _ -> false -let get_failing_constraint _ = Formula.True +let get_failing_constraint _ = Expr.true_ let add_debugger_variables = WislSHeap.add_debugger_variables let sure_is_nonempty t = not (WislSHeap.is_empty t) From b39426c65c4bc33c69582453d4680d5bce584d8d Mon Sep 17 00:00:00 2001 From: N1ark Date: Wed, 25 Dec 2024 12:52:24 +0100 Subject: [PATCH 37/54] Update ppx_sat --- ppx_sat/runtime/ppx_sat_runtime.ml | 2 +- ppx_sat/runtime/ppx_sat_runtime.mli | 8 ++++---- ppx_sat/test/test.ml | 21 ++++++++++++--------- 3 files changed, 17 insertions(+), 14 deletions(-) diff --git a/ppx_sat/runtime/ppx_sat_runtime.ml b/ppx_sat/runtime/ppx_sat_runtime.ml index 52c40f87..2e8d2090 100644 --- a/ppx_sat/runtime/ppx_sat_runtime.ml +++ b/ppx_sat/runtime/ppx_sat_runtime.ml @@ -7,4 +7,4 @@ let if_sure_then_else guard ~then_branch ~else_branch = Delayed.if_sure guard ~then_:then_branch ~else_:else_branch let branch_entailment = Delayed.branch_entailment -let true_formula = Gil_syntax.Formula.True +let true_formula = Gil_syntax.Expr.true_ diff --git a/ppx_sat/runtime/ppx_sat_runtime.mli b/ppx_sat/runtime/ppx_sat_runtime.mli index 8163b05e..3b0eaaea 100644 --- a/ppx_sat/runtime/ppx_sat_runtime.mli +++ b/ppx_sat/runtime/ppx_sat_runtime.mli @@ -2,10 +2,10 @@ open Monadic.Delayed open Gil_syntax val if_then_else : - Formula.t -> then_branch:(unit -> 'a t) -> else_branch:(unit -> 'a t) -> 'a t + Expr.t -> then_branch:(unit -> 'a t) -> else_branch:(unit -> 'a t) -> 'a t val if_sure_then_else : - Formula.t -> then_branch:(unit -> 'a t) -> else_branch:(unit -> 'a t) -> 'a t + Expr.t -> then_branch:(unit -> 'a t) -> else_branch:(unit -> 'a t) -> 'a t -val branch_entailment : (Formula.t * (unit -> 'a t)) list -> 'a t -val true_formula : Gil_syntax.Formula.t +val branch_entailment : (Expr.t * (unit -> 'a t)) list -> 'a t +val true_formula : Expr.t diff --git a/ppx_sat/test/test.ml b/ppx_sat/test/test.ml index d1ff49f3..3fa9381d 100644 --- a/ppx_sat/test/test.ml +++ b/ppx_sat/test/test.ml @@ -1,13 +1,16 @@ open Gillian open Gil_syntax open Monadic.Delayed -open Formula.Infix + +let add = ( + ) + +open Expr.Infix open Monadic.Delayed.Syntax let zero = Expr.int 0 let one = Expr.int 1 let two = Expr.int 2 -let int_pat n x = x #== (Expr.int n) +let int_pat n x = x == Expr.int n let zero_pat = int_pat 0 let one_pat = int_pat 1 let two_pat = int_pat 2 @@ -22,21 +25,21 @@ module type S = sig end module Test_if_sat = struct - let computation t = if%sat t #>= one then return 10 else return 0 + let computation t = if%sat t >= one then return 10 else return 0 let process x = let* z = computation x in let* y = - if%sat x #<= zero then return (-1) + if%sat x <= zero then return (-1) else - if%sat x #<= one then return 0 - else if%sat x #>= two then return 2 else return 1 + if%sat x <= one then return 0 + else if%sat x >= two then return 2 else return 1 in - return (z + y) + return (add z y) let starting_pc x = Monadic.Pc.make - ~pfs:(Engine.PFS.of_list [ Formula.Not x #== one ]) + ~pfs:(Engine.PFS.of_list [ not (x == one) ]) ~gamma:(Engine.Type_env.init ()) ~matching:false () let results = @@ -60,7 +63,7 @@ module Test_match_ent = struct let pc_with_two x = Monadic.Pc.make - ~pfs:(Engine.PFS.of_list [ x #== two ]) + ~pfs:(Engine.PFS.of_list [ x == two ]) ~gamma:(Engine.Type_env.init ()) ~matching:false () let results_no_info = From b29f6df2b5968da276ac3b6c3de0722451273eb1 Mon Sep 17 00:00:00 2001 From: N1ark Date: Wed, 25 Dec 2024 12:52:38 +0100 Subject: [PATCH 38/54] Update core --- GillianCore/GIL_Syntax/Expr.ml | 39 ++++++++++--------- GillianCore/GIL_Syntax/Gil_syntax.mli | 1 + .../command_line/s_interpreter_console.ml | 2 +- .../debugging/debugger/base_debugger.ml | 2 +- .../engine/symbolic_semantics/SMemory.ml | 6 +-- 5 files changed, 26 insertions(+), 24 deletions(-) diff --git a/GillianCore/GIL_Syntax/Expr.ml b/GillianCore/GIL_Syntax/Expr.ml index 6672b9f2..6abe3145 100644 --- a/GillianCore/GIL_Syntax/Expr.ml +++ b/GillianCore/GIL_Syntax/Expr.ml @@ -241,6 +241,8 @@ module Infix = struct | UnOp (IUnaryMinus, z) -> z | z -> UnOp (IUnaryMinus, z) + let forall params f = ForAll (params, f) + let not a = match a with | Lit (Bool a) -> Lit (Bool (not a)) @@ -436,8 +438,7 @@ let rec full_pp fmt e = let to_expr (le : t) : t = le (** From expression to list, if possible *) -let to_list (le : t) : t list option = - match le with +let to_list : t -> t list option = function | EList les -> Some les | Lit (LList les) -> Some (List.map (fun x -> Lit x) les) | _ -> None @@ -450,20 +451,19 @@ let to_literal = function | _ -> None (** Get all the logical variables in --e-- *) -let lvars (le : t) : SS.t = - Visitors.Collectors.lvar_collector#visit_expr SS.empty le +let lvars : t -> SS.t = Visitors.Collectors.lvar_collector#visit_expr SS.empty (** Get all the abstract locations in --e-- *) -let alocs (le : t) : SS.t = Visitors.Collectors.aloc_collector#visit_expr () le +let alocs : t -> SS.t = Visitors.Collectors.aloc_collector#visit_expr () (** Get all the concrete locations in --e-- *) -let clocs (le : t) : SS.t = Visitors.Collectors.cloc_collector#visit_expr () le +let clocs : t -> SS.t = Visitors.Collectors.cloc_collector#visit_expr () -let locs (le : t) : SS.t = Visitors.Collectors.loc_collector#visit_expr () le +let locs : t -> SS.t = Visitors.Collectors.loc_collector#visit_expr () (** Get all substitutables in --e-- *) -let substitutables (le : t) : SS.t = - Visitors.Collectors.substitutable_collector#visit_expr () le +let substitutables : t -> SS.t = + Visitors.Collectors.substitutable_collector#visit_expr () let rec is_concrete (le : t) : bool = let f = is_concrete in @@ -482,19 +482,17 @@ let rec is_concrete (le : t) : bool = | LstSub (e1, e2, e3) -> loop [ e1; e2; e3 ] | NOp (_, les) | EList les | ESet les -> loop les -let is_concrete_zero_i (le : t) : bool = - match le with +let is_concrete_zero_i : t -> bool = function | Lit (Int z) -> Z.equal Z.zero z | _ -> false (** Get all the variables in --e-- *) -let vars (le : t) : SS.t = Visitors.Collectors.var_collector#visit_expr () le +let vars : t -> SS.t = Visitors.Collectors.var_collector#visit_expr () (** Are all expressions in the list literals? *) let all_literals les = List.for_all - (fun x -> - match x with + (function | Lit _ -> true | _ -> false) les @@ -552,8 +550,14 @@ let rec as_boolean_expr (e : t) : (t * t) option = let open Syntaxes.Option in let f = as_boolean_expr in match e with + (* TODO: Do these two cases ever happen? If not, then this fn just does two things: + - types an Expr as a boolean expression + - negates this expr + And in this case we can simplify this into two differents fns, one for typing it and one + for negating it, because often we us this fn without using the negated expr, so it's + wasted work. *) | LVar _ | PVar _ -> Some (BinOp (e, Equal, true_), BinOp (e, Equal, false_)) - | Lit (Bool b) -> Some (bool b, bool (not b)) + | Lit (Bool b) -> Some (e, bool (not b)) | BinOp (e1, FLessThan, e2) -> Some (e, BinOp (e2, FLessThanEqual, e1)) | BinOp (e1, ILessThan, e2) -> Some (e, BinOp (e2, ILessThanEqual, e1)) | BinOp (e1, FLessThanEqual, e2) -> Some (e, BinOp (e2, FLessThan, e1)) @@ -618,7 +622,7 @@ let base_elements (expr : t) : t list = in v#visit_expr () expr -let pvars (e : t) : SS.t = Visitors.Collectors.pvar_collector#visit_expr () e +let pvars : t -> SS.t = Visitors.Collectors.pvar_collector#visit_expr () let var_to_expr (x : string) : t = if Names.is_lvar_name x then LVar x @@ -626,8 +630,7 @@ let var_to_expr (x : string) : t = else if is_pvar_name x then PVar x else raise (Failure ("var_to_expr: Impossible matchable: " ^ x)) -let is_matchable (e : t) : bool = - match e with +let is_matchable = function | PVar _ | LVar _ | ALoc _ | UnOp (LstLen, PVar _) | UnOp (LstLen, LVar _) -> true | _ -> false diff --git a/GillianCore/GIL_Syntax/Gil_syntax.mli b/GillianCore/GIL_Syntax/Gil_syntax.mli index 809dbbcb..3d4ca0d3 100644 --- a/GillianCore/GIL_Syntax/Gil_syntax.mli +++ b/GillianCore/GIL_Syntax/Gil_syntax.mli @@ -336,6 +336,7 @@ module Expr : sig (** Booleans *) val not : t -> t + val forall : (string * Type.t option) list -> t -> t val ( == ) : t -> t -> t val ( && ) : t -> t -> t val ( || ) : t -> t -> t diff --git a/GillianCore/command_line/s_interpreter_console.ml b/GillianCore/command_line/s_interpreter_console.ml index fab8a7da..7579b5dd 100644 --- a/GillianCore/command_line/s_interpreter_console.ml +++ b/GillianCore/command_line/s_interpreter_console.ml @@ -49,7 +49,7 @@ struct in let fs = match f with - | Some f -> [ Formula.Not f ] + | Some f -> [ Expr.Infix.not f ] | None -> [] in let subst = SState.sat_check_f error_state fs in diff --git a/GillianCore/debugging/debugger/base_debugger.ml b/GillianCore/debugging/debugger/base_debugger.ml index 5280d82c..914632da 100644 --- a/GillianCore/debugging/debugger/base_debugger.ml +++ b/GillianCore/debugging/debugger/base_debugger.ml @@ -231,7 +231,7 @@ struct let open Variable in State.get_pfs state |> PFS.to_list |> List.map (fun formula -> - let value = Fmt.to_to_string (Fmt.hbox Formula.pp) formula in + let value = Fmt.to_to_string (Fmt.hbox Expr.pp) formula in { name = ""; value; type_ = None; var_ref = 0 }) |> List.sort (fun v w -> Stdlib.compare v.value w.value) diff --git a/GillianCore/engine/symbolic_semantics/SMemory.ml b/GillianCore/engine/symbolic_semantics/SMemory.ml index 2d68466e..59748e7a 100644 --- a/GillianCore/engine/symbolic_semantics/SMemory.ml +++ b/GillianCore/engine/symbolic_semantics/SMemory.ml @@ -4,10 +4,10 @@ module type S = sig type init_data (** Type of GIL values *) - type vt = SVal.M.t + type vt := SVal.M.t (** Type of GIL substitutions *) - type st = SVal.SESubst.t + type st := SVal.SESubst.t type err_t [@@deriving yojson, show] @@ -84,8 +84,6 @@ end module Dummy : S with type init_data = unit = struct type init_data = unit - type vt = SVal.M.t - type st = SVal.SESubst.t type err_t = unit [@@deriving yojson, show] type t = unit [@@deriving yojson] From 9f47e0df898bab6c0012df68212d21966699643d Mon Sep 17 00:00:00 2001 From: N1ark Date: Wed, 25 Dec 2024 14:03:30 +0100 Subject: [PATCH 39/54] Simplify parser --- GillianCore/gil_parser/GIL_Parser.mly | 88 +++++++-------------------- 1 file changed, 23 insertions(+), 65 deletions(-) diff --git a/GillianCore/gil_parser/GIL_Parser.mly b/GillianCore/gil_parser/GIL_Parser.mly index f8c979c2..b3053b10 100644 --- a/GillianCore/gil_parser/GIL_Parser.mly +++ b/GillianCore/gil_parser/GIL_Parser.mly @@ -278,7 +278,6 @@ let normalised_lvar_r = Str.regexp "##NORMALISED_LVAR" %type unop_target %type binop_target %type nop_target -%type pure_assertion_target %type <(Annot.t, string) Prog.t * Yojson.Safe.t> gmain_target %type top_level_expr_target @@ -720,9 +719,9 @@ g_assertion_target: (* (P) *) | LBRACE; g_assertion_target; RBRACE { $2 } -(* pure *) - | pure_assertion_target - { [ Asrt.Pure $1 ] } +(* (pure) *) + | LBRACE; expr_target; RBRACE + { [ Asrt.Pure $2 ] } ; g_macro_target: @@ -801,11 +800,11 @@ g_logic_cmd_target: { let (name, params) = macro in LCmd.Macro (name, params) } (* assert (a) *) - | ASSERT; LBRACE; a = pure_assertion_target; RBRACE + | ASSERT; LBRACE; a = expr_target; RBRACE { LCmd.Assert a } (* assume (a) *) - | ASSUME; LBRACE; a = pure_assertion_target; RBRACE + | ASSUME; LBRACE; a = expr_target; RBRACE { LCmd.Assume a } (* assume_type (x, t) *) @@ -818,7 +817,7 @@ g_logic_cmd_target: { LCmd.FreshSVar (v) } (* branch (fo) *) - | BRANCH; LBRACE; fo = pure_assertion_target; RBRACE + | BRANCH; LBRACE; fo = expr_target; RBRACE { LCmd.Branch fo } ; @@ -827,7 +826,7 @@ g_pred_def_target: { defs } g_pred_facts_target: - FACTS; COLON; facts = separated_nonempty_list(AND, pure_assertion_target); SCOLON + FACTS; COLON; facts = separated_nonempty_list(AND, expr_target); SCOLON { facts } g_pred_cost_target: @@ -1008,61 +1007,6 @@ existentials_target: { xs } ; -pure_assertion_target: -(* P /\ Q *) - | left_ass=expr_target; LAND; right_ass=expr_target - { Expr.BinOp (left_ass, Equal, right_ass) } -(* A ==> B *) - | left_ass = expr_target; LIMPLIES; right_ass=expr_target - { Expr.BinOp (left_ass, Impl, right_ass) } -(* P \/ Q *) - | left_ass=expr_target; LOR; right_ass=expr_target - { Expr.BinOp (left_ass, Or, right_ass) } -(* ! Q *) - | LNOT; ass=expr_target - { Expr.UnOp (Not, ass) } -(* true *) - | LTRUE - { Expr.Lit (Bool true) } -(* false *) - | LFALSE - { Expr.Lit (Bool false) } -(* E == E *) - | left_expr=expr_target; LEQUAL; right_expr=expr_target - { Expr.BinOp (left_expr, Equal, right_expr) } -(* E i<# E *) - | left_expr=expr_target; ILLESSTHAN; right_expr=expr_target - { Expr.BinOp (left_expr, ILessThan, right_expr) } -(* E <# E *) - | left_expr=expr_target; FLLESSTHAN; right_expr=expr_target - { Expr.BinOp (left_expr, FLessThan, right_expr) } -(* E i<=# E *) - | left_expr=expr_target; ILLESSTHANEQUAL; right_expr=expr_target - { Expr.BinOp (left_expr, ILessThanEqual, right_expr) } -(* E <=# E *) - | left_expr=expr_target; FLLESSTHANEQUAL; right_expr=expr_target - { Expr.BinOp (left_expr, FLessThanEqual, right_expr) } -(* E s<# E *) - | left_expr=expr_target; LSLESSTHAN; right_expr=expr_target - { Expr.BinOp (left_expr, StrLess, right_expr) } -(* E --e-- E *) - | left_expr=expr_target; LSETMEM; right_expr=expr_target - { Expr.BinOp (left_expr, SetMem, right_expr) } -(* E --s-- E *) - | left_expr=expr_target; LSETSUB; right_expr=expr_target - { Expr.BinOp (left_expr, SetSub, right_expr) } -(* forall X, Y, Z . P *) - | LFORALL; vars = separated_nonempty_list(COMMA, lvar_type_target); DOT; ass = expr_target - { Expr.ForAll (vars, ass) } -(* is-int E *) - | ISINT; expr=expr_target - { Expr.UnOp (IsInt, expr) } -(* (P) *) - | LBRACE; f=pure_assertion_target; RBRACE - { f } -; - - lvar_type_target: | lvar = just_logic_variable_target; COLON; the_type = type_target @@ -1101,7 +1045,9 @@ lit_target: | NULL { Literal.Null } | EMPTY { Literal.Empty } | constant_target { Literal.Constant $1 } + | LTRUE | TRUE { Literal.Bool true } + | LFALSE | FALSE { Literal.Bool false } | FLOAT { Literal.Num $1 } | n = INTEGER { Literal.Int n } @@ -1122,23 +1068,31 @@ nop_target: ; binop_target: + | LEQUAL | EQ { BinOp.Equal } + | ILLESSTHAN | ILT { BinOp.ILessThan } + | ILLESSTHANEQUAL | ILE { BinOp.ILessThanEqual } | IPLUS { BinOp.IPlus } | IMINUS { BinOp.IMinus } | ITIMES { BinOp.ITimes } | IDIV { BinOp.IDiv } | IMOD { BinOp.IMod } + | FLLESSTHAN | FLT { BinOp.FLessThan } + | FLLESSTHANEQUAL | FLE { BinOp.FLessThanEqual } | FPLUS { BinOp.FPlus } | FMINUS { BinOp.FMinus } | FTIMES { BinOp.FTimes } | FDIV { BinOp.FDiv } | FMOD { BinOp.FMod } + | LSLESSTHAN | SLT { BinOp.StrLess } + | LAND | AND { BinOp.And } + | LOR | OR { BinOp.Or } | LIMPLIES { BinOp.Impl } | BITWISEAND { BinOp.BitwiseAnd } @@ -1157,12 +1111,15 @@ binop_target: | M_POW { BinOp.M_pow } | STRCAT { BinOp.StrCat } | SETDIFF { BinOp.SetDiff } + | LSETMEM | SETMEM { BinOp.SetMem } + | LSETSUB | SETSUB { BinOp.SetSub } ; unop_target: (* Unary minus defined in (l)expr_target *) + | LNOT | NOT { UnOp.Not } | BITWISENOT { UnOp.BitwiseNot } | M_ISNAN { UnOp.M_isNaN } @@ -1193,8 +1150,9 @@ unop_target: | LSTREV { UnOp.LstRev } | STRLEN { UnOp.StrLen } | SETTOLIST { UnOp.SetToList } - | INTTONUM { UnOp.IntToNum } - | NUMTOINT { UnOp.NumToInt } + | INTTONUM { UnOp.IntToNum } + | NUMTOINT { UnOp.NumToInt } + | ISINT { UnOp.IsInt } ; constant_target: From f81d4021537a5993657782a37a7bcb15d8e5f15b Mon Sep 17 00:00:00 2001 From: N1ark Date: Wed, 25 Dec 2024 16:56:59 +0100 Subject: [PATCH 40/54] Small simplifications, fix `Expr.(> >= >. >=.)` --- Gillian-C/lib/SHeapTree.ml | 2 +- GillianCore/GIL_Syntax/Expr.ml | 17 +++++++++-------- GillianCore/GIL_Syntax/Literal.ml | 2 +- GillianCore/engine/Abstraction/Normaliser.ml | 6 +++--- GillianCore/engine/Abstraction/Preds.ml | 3 ++- GillianCore/engine/FOLogic/FOSolver.ml | 11 ++++++----- GillianCore/engine/FOLogic/Reduction.ml | 10 +++++----- GillianCore/engine/FOLogic/Simplifications.ml | 2 +- GillianCore/engine/FOLogic/typing.ml | 6 +++--- .../engine/concrete_semantics/CExprEval.ml | 10 +++++----- GillianCore/smt/smt.ml | 2 +- 11 files changed, 37 insertions(+), 34 deletions(-) diff --git a/Gillian-C/lib/SHeapTree.ml b/Gillian-C/lib/SHeapTree.ml index f829ba75..76657b09 100644 --- a/Gillian-C/lib/SHeapTree.ml +++ b/Gillian-C/lib/SHeapTree.ml @@ -1404,7 +1404,7 @@ let _check_valid_alignment chunk ofs = let al_expr = Expr.int al in let divides x y = let open Expr.Infix in - Expr.(y == int 0) || Expr.imod y x == Expr.int 0 + Expr.(y == zero_i || imod y x == zero_i) in if%sat divides al_expr ofs then DR.ok () else DR.error (InvalidAlignment { offset = ofs; alignment = al }) diff --git a/GillianCore/GIL_Syntax/Expr.ml b/GillianCore/GIL_Syntax/Expr.ml index 6abe3145..01ea4653 100644 --- a/GillianCore/GIL_Syntax/Expr.ml +++ b/GillianCore/GIL_Syntax/Expr.ml @@ -254,10 +254,10 @@ module Infix = struct | a, b when equal a b -> Lit (Bool true) | _ -> BinOp (a, Equal, b) - let lt = ( < ) - let lte = ( <= ) - let gt = ( > ) - let gte = ( >= ) + let lt = Stdlib.( < ) + let lte = Stdlib.( <= ) + let gt = Stdlib.( > ) + let gte = Stdlib.( >= ) let ( < ) a b = match (a, b) with @@ -272,12 +272,12 @@ module Infix = struct let ( > ) a b = match (a, b) with | Lit (Int x), Lit (Int y) -> bool (gt x y) - | _ -> BinOp (b, ILessThanEqual, a) + | _ -> BinOp (b, ILessThan, a) let ( >= ) a b = match (a, b) with | Lit (Int x), Lit (Int y) -> bool (gte x y) - | _ -> BinOp (b, ILessThan, a) + | _ -> BinOp (b, ILessThanEqual, a) let ( <. ) a b = match (a, b) with @@ -292,12 +292,12 @@ module Infix = struct let ( >. ) a b = match (a, b) with | Lit (Num x), Lit (Num y) -> bool (gt x y) - | _ -> BinOp (b, FLessThanEqual, a) + | _ -> BinOp (b, FLessThan, a) let ( >=. ) a b = match (a, b) with | Lit (Num x), Lit (Num y) -> bool (gte x y) - | _ -> BinOp (b, FLessThan, a) + | _ -> BinOp (b, FLessThanEqual, a) let ( && ) a b = match (a, b) with @@ -399,6 +399,7 @@ let rec pp fmt e = match op with | LstNth | StrNth | LstRepeat -> Fmt.pf fmt "%s(%a, %a)" (BinOp.str op) pp e1 pp e2 + | Equal -> Fmt.pf fmt "@[(%a %s %a)@]" pp e1 (BinOp.str op) pp e2 | _ -> Fmt.pf fmt "(%a %s %a)" pp e1 (BinOp.str op) pp e2) | LstSub (e1, e2, e3) -> Fmt.pf fmt "l-sub(%a, %a, %a)" pp e1 pp e2 pp e3 (* (uop e) *) diff --git a/GillianCore/GIL_Syntax/Literal.ml b/GillianCore/GIL_Syntax/Literal.ml index b3a3bfde..84b9a987 100644 --- a/GillianCore/GIL_Syntax/Literal.ml +++ b/GillianCore/GIL_Syntax/Literal.ml @@ -40,7 +40,7 @@ let rec pp fmt x = | Empty -> Fmt.string fmt "empty" | Nono -> Fmt.string fmt "none" | Constant c -> Fmt.string fmt (Constant.str c) - | Bool b -> if b then Fmt.string fmt "true" else Fmt.string fmt "false" + | Bool b -> Fmt.pf fmt "%b" b | Int i -> Fmt.pf fmt "%ai" Z.pp_print i | Num n -> Fmt.pf fmt "%F" n | String x -> Fmt.pf fmt "\"%s\"" x diff --git a/GillianCore/engine/Abstraction/Normaliser.ml b/GillianCore/engine/Abstraction/Normaliser.ml index 275b3934..7182ef4f 100644 --- a/GillianCore/engine/Abstraction/Normaliser.ml +++ b/GillianCore/engine/Abstraction/Normaliser.ml @@ -179,7 +179,7 @@ module Make (SPState : PState.S) = struct | NOp (_, _) | ESet _ -> Lit (Type SetType)) | _ -> UnOp (uop, nle1))) | EList le_list -> - let n_le_list = List.map (fun le -> f le) le_list in + let n_le_list = List.map f le_list in let all_literals, lit_list = List.fold_left (fun (ac, list) le -> @@ -190,10 +190,10 @@ module Make (SPState : PState.S) = struct in if all_literals then Lit (LList lit_list) else EList n_le_list | ESet le_list -> - let n_le_list = List.map (fun le -> f le) le_list in + let n_le_list = List.map f le_list in ESet n_le_list | NOp (op, le_list) -> - let n_le_list = List.map (fun le -> f le) le_list in + let n_le_list = List.map f le_list in NOp (op, n_le_list) | LstSub (le1, le2, le3) -> ( let nle1 = f le1 in diff --git a/GillianCore/engine/Abstraction/Preds.ml b/GillianCore/engine/Abstraction/Preds.ml index 7d0010ad..547d6ed4 100644 --- a/GillianCore/engine/Abstraction/Preds.ml +++ b/GillianCore/engine/Abstraction/Preds.ml @@ -100,8 +100,9 @@ let get_alocs (preds : t) : SS.t = (** Printing function *) let pp_pabs fmt pa = + let exprpp fmt e = Fmt.pf fmt "@[%a@]" Expr.pp e in let pname, vs = pa in - Fmt.pf fmt "%s(%a)" pname (Fmt.list ~sep:(Fmt.any ", ") Expr.pp) vs + Fmt.pf fmt "%s(%a)" pname (Fmt.list ~sep:(Fmt.any ", ") exprpp) vs let pp fmt preds = let lpreds = to_list preds in diff --git a/GillianCore/engine/FOLogic/FOSolver.ml b/GillianCore/engine/FOLogic/FOSolver.ml index a6e2e16a..d5d16868 100644 --- a/GillianCore/engine/FOLogic/FOSolver.ml +++ b/GillianCore/engine/FOLogic/FOSolver.ml @@ -95,17 +95,18 @@ let check_satisfiability result let sat ~matching ~pfs ~gamma formula : bool = - let formula = Reduction.reduce_formula ~matching ~pfs ~gamma formula in - match formula with + let formula' = Reduction.reduce_formula ~matching ~pfs ~gamma formula in + match formula' with | Lit (Bool b) -> - Logging.verbose (fun fmt -> fmt "Discharged sat before SMT"); + Logging.verbose (fun fmt -> + fmt "Discharged sat before SMT @[%a -> %b@]" Expr.pp formula b); b | _ -> let relevant_info = - (Expr.pvars formula, Expr.lvars formula, Expr.locs formula) + (Expr.pvars formula', Expr.lvars formula', Expr.locs formula') in check_satisfiability ~matching ~relevant_info - (formula :: PFS.to_list pfs) + (formula' :: PFS.to_list pfs) gamma (** ************ diff --git a/GillianCore/engine/FOLogic/Reduction.ml b/GillianCore/engine/FOLogic/Reduction.ml index bfaba885..4e47c9bc 100644 --- a/GillianCore/engine/FOLogic/Reduction.ml +++ b/GillianCore/engine/FOLogic/Reduction.ml @@ -469,15 +469,15 @@ let rec set_member (pfs : Expr.t list) m s = match s with | Expr.LVar _ -> m = s | Expr.ESet s -> List.mem m s - | Expr.NOp (SetUnion, les) -> List.exists (fun x -> f x) les - | Expr.NOp (SetInter, les) -> List.for_all (fun x -> f x) les + | Expr.NOp (SetUnion, les) -> List.exists f les + | Expr.NOp (SetInter, les) -> List.for_all f les | _ -> List.mem (Expr.BinOp (m, SetMem, s)) pfs let rec not_set_member pfs m s = let f = not_set_member pfs m in match s with - | Expr.NOp (SetUnion, les) -> List.for_all (fun x -> f x) les - | Expr.NOp (SetInter, les) -> List.exists (fun x -> f x) les + | Expr.NOp (SetUnion, les) -> List.for_all f les + | Expr.NOp (SetInter, les) -> List.exists f les | Expr.ESet les -> List.for_all (fun le -> is_different pfs m le = Some true) les | _ -> List.mem (Expr.UnOp (Not, BinOp (m, SetMem, s))) pfs @@ -2906,7 +2906,7 @@ let rec reduce_formula_loop UnOp (Not, BinOp (rleb, SetMem, rler)) ) | BinOp (leb, SetMem, ESet les) -> let rleb = fe leb in - let rles = List.map (fun le -> fe le) les in + let rles = List.map fe les in let result = List.map (fun le -> Expr.BinOp (rleb, Equal, le)) rles in Expr.disjunct result | UnOp (IsInt, e) -> ( diff --git a/GillianCore/engine/FOLogic/Simplifications.ml b/GillianCore/engine/FOLogic/Simplifications.ml index 733c3c2c..12f72b16 100644 --- a/GillianCore/engine/FOLogic/Simplifications.ml +++ b/GillianCore/engine/FOLogic/Simplifications.ml @@ -461,7 +461,7 @@ let simplify_pfs_and_gamma let eqs = List.map (fun le -> Expr.BinOp (le, Equal, EList [])) les in - List.iter (fun eq -> extend_with eq) eqs; + List.iter extend_with eqs; `Filter (* Two list concats, Satan save us *) | BinOp (NOp (LstCat, lcat), Equal, NOp (LstCat, rcat)) -> ( diff --git a/GillianCore/engine/FOLogic/typing.ml b/GillianCore/engine/FOLogic/typing.ml index 62152568..edb1327e 100644 --- a/GillianCore/engine/FOLogic/typing.ml +++ b/GillianCore/engine/FOLogic/typing.ml @@ -214,11 +214,11 @@ let rec infer_types_expr gamma le : unit = (* Set union and intersection - all members must be sets, plus any additional information from the members themselves *) | NOp (SetUnion, lle) | NOp (SetInter, lle) -> e le SetType; - List.iter (fun le -> f le) lle + List.iter f lle | NOp (LstCat, lle) -> e le ListType; - List.iter (fun le -> f le) lle - | EList lle | ESet lle -> List.iter (fun le -> f le) lle + List.iter f lle + | EList lle | ESet lle -> List.iter f lle | BinOp (le1, op, le2) -> ( match op with | Equal -> () diff --git a/GillianCore/engine/concrete_semantics/CExprEval.ml b/GillianCore/engine/concrete_semantics/CExprEval.ml index 8cab77b7..8e5b2193 100644 --- a/GillianCore/engine/concrete_semantics/CExprEval.ml +++ b/GillianCore/engine/concrete_semantics/CExprEval.ml @@ -46,7 +46,7 @@ let evaluate_unop (op : UnOp.t) (lit : CVal.M.t) : CVal.M.t = | Not -> let b = as_bool lit in Bool (not b) - | IUnaryMinus -> unary_int_thing lit (fun x -> Z.neg x) + | IUnaryMinus -> unary_int_thing lit Z.neg | FUnaryMinus -> unary_num_thing lit (fun x -> -.x) | BitwiseNot -> unary_num_thing lit int32_bitwise_not | M_abs -> unary_num_thing lit abs_float @@ -217,14 +217,14 @@ let rec evaluate_binop | Num n when is_int n -> String (String.make 1 s.[int_of_float n]) | Num -0. -> String (String.make 1 s.[0]) | _ -> typeerr "number" lit2) - | ILessThan -> binary_int_bool_thing lit1 lit2 (fun x y -> x < y) - | FLessThan -> binary_num_bool_thing lit1 lit2 (fun x y -> x < y) + | ILessThan -> binary_int_bool_thing lit1 lit2 ( < ) + | FLessThan -> binary_num_bool_thing lit1 lit2 ( < ) | StrLess -> let s1 = as_str lit1 in let s2 = as_str lit2 in Bool (s1 < s2) - | ILessThanEqual -> binary_int_bool_thing lit1 lit2 (fun x y -> x <= y) - | FLessThanEqual -> binary_num_bool_thing lit1 lit2 (fun x y -> x <= y) + | ILessThanEqual -> binary_int_bool_thing lit1 lit2 ( <= ) + | FLessThanEqual -> binary_num_bool_thing lit1 lit2 ( <= ) | IPlus -> binary_int_thing lit1 lit2 Z.add | IMinus -> binary_int_thing lit1 lit2 Z.sub | ITimes -> binary_int_thing lit1 lit2 Z.mul diff --git a/GillianCore/smt/smt.ml b/GillianCore/smt/smt.ml index 49fdee63..c518ffc6 100644 --- a/GillianCore/smt/smt.ml +++ b/GillianCore/smt/smt.ml @@ -1064,5 +1064,5 @@ let lift_model let () = let decls = List.rev !init_decls in - let () = decls |> List.iter (fun decl -> cmd decl) in + let () = decls |> List.iter cmd in cmd (push 1) From 3c0625c2244a34fbbff57d090dc042bac6176374 Mon Sep 17 00:00:00 2001 From: N1ark Date: Wed, 25 Dec 2024 22:29:19 +0100 Subject: [PATCH 41/54] Simplify parser, fix reductions --- GillianCore/engine/FOLogic/Reduction.ml | 12 +++--- GillianCore/engine/FOLogic/Simplifications.ml | 4 +- GillianCore/gil_parser/GIL_Lexer.mll | 26 ++++++------ GillianCore/gil_parser/GIL_Parser.mly | 41 ++++--------------- GillianCore/smt/smt.ml | 7 +++- 5 files changed, 34 insertions(+), 56 deletions(-) diff --git a/GillianCore/engine/FOLogic/Reduction.ml b/GillianCore/engine/FOLogic/Reduction.ml index 4e47c9bc..debf64c8 100644 --- a/GillianCore/engine/FOLogic/Reduction.ml +++ b/GillianCore/engine/FOLogic/Reduction.ml @@ -2867,20 +2867,20 @@ let rec reduce_formula_loop | BinOp (Lit (Int z), ILessThanEqual, UnOp (LstLen, _)) when Z.equal z Z.zero -> Expr.true_ | BinOp (e1, (FLessThan as op), e2) | BinOp (e1, (ILessThan as op), e2) -> - let rev : BinOp.t = + let op_e : BinOp.t = if op = FLessThan then FLessThanEqual else ILessThanEqual in - if PFS.mem pfs (BinOp (e2, rev, e1)) then Expr.false_ + if PFS.mem pfs (BinOp (e2, op_e, e1)) then Expr.false_ else if PFS.mem pfs (BinOp (e2, op, e1)) then Expr.false_ else fe (Expr.BinOp (e1, op, e2)) | BinOp (e1, (FLessThanEqual as op), e2) | BinOp (e1, (ILessThanEqual as op), e2) -> - let rev : BinOp.t = + let op_ne : BinOp.t = if op = FLessThanEqual then FLessThan else ILessThan in - if PFS.mem pfs (BinOp (e2, rev, e1)) then BinOp (e1, Equal, e2) - else if PFS.mem pfs (BinOp (e1, op, e2)) then Expr.true_ - else if PFS.mem pfs (BinOp (e2, op, e1)) then Expr.false_ + if PFS.mem pfs (BinOp (e2, op, e1)) then BinOp (e1, Equal, e2) + else if PFS.mem pfs (BinOp (e1, op_ne, e2)) then Expr.true_ + else if PFS.mem pfs (BinOp (e2, op_ne, e1)) then Expr.false_ else fe (Expr.BinOp (e1, op, e2)) | BinOp (leb, SetMem, NOp ((SetUnion as op), lle)) | BinOp (leb, SetMem, NOp ((SetInter as op), lle)) -> ( diff --git a/GillianCore/engine/FOLogic/Simplifications.ml b/GillianCore/engine/FOLogic/Simplifications.ml index 12f72b16..701b3882 100644 --- a/GillianCore/engine/FOLogic/Simplifications.ml +++ b/GillianCore/engine/FOLogic/Simplifications.ml @@ -904,8 +904,8 @@ let simplify_pfs_and_gamma done; L.verbose (fun m -> m "PFS/Gamma simplification completed:\n"); - L.(verbose (fun m -> m "PFS:@\n%a@\n" PFS.pp lpfs)); - L.(verbose (fun m -> m "Gamma:@\n%a@\n" Type_env.pp gamma)); + L.verbose (fun m -> m "PFS:@\n%a@\n" PFS.pp lpfs); + L.verbose (fun m -> m "Gamma:@\n%a@\n" Type_env.pp gamma); let cached_simplification = { diff --git a/GillianCore/gil_parser/GIL_Lexer.mll b/GillianCore/gil_parser/GIL_Lexer.mll index ea58bf0b..cbe52d9c 100644 --- a/GillianCore/gil_parser/GIL_Lexer.mll +++ b/GillianCore/gil_parser/GIL_Lexer.mll @@ -28,7 +28,9 @@ "null", GIL_Parser.NULL; "empty", GIL_Parser.EMPTY; "true", GIL_Parser.TRUE; + "True", GIL_Parser.TRUE; "false", GIL_Parser.FALSE; + "False", GIL_Parser.FALSE; "nan", GIL_Parser.NAN; "inf", GIL_Parser.INFINITY; "nil", GIL_Parser.LSTNIL; @@ -87,8 +89,6 @@ "none", GIL_Parser.LNONE; (* Logic assertions *) - "True", GIL_Parser.LTRUE; - "False", GIL_Parser.LFALSE; "emp", GIL_Parser.LEMP; "types", GIL_Parser.LTYPES; "forall", GIL_Parser.LFORALL; @@ -181,11 +181,14 @@ rule read = parse (* Binary operators *) | "==>" { GIL_Parser.LIMPLIES } + | "==" | "=" { GIL_Parser.EQ } | "-*" { GIL_Parser.WAND } + | "i<#" | "i<" { GIL_Parser.ILT } | "i>" { GIL_Parser.IGT } + | "i<=#" | "i<=" { GIL_Parser.ILE } | "i>=" { GIL_Parser.IGE } | "i+" { GIL_Parser.IPLUS } @@ -194,8 +197,10 @@ rule read = parse | "i/" { GIL_Parser.IDIV } | "i%" { GIL_Parser.IMOD } + | "<#" | "<" { GIL_Parser.FLT } | ">" { GIL_Parser.FGT } + | "<=#" | "<=" { GIL_Parser.FLE } | ">=" { GIL_Parser.FGE } | "+" { GIL_Parser.FPLUS } @@ -204,6 +209,7 @@ rule read = parse | "/" { GIL_Parser.FDIV } | "%" { GIL_Parser.FMOD } + | "s<#" | "s<" { GIL_Parser.SLT } | "&" { GIL_Parser.BITWISEAND } | "|" { GIL_Parser.BITWISEOR } @@ -223,10 +229,10 @@ rule read = parse | "-u-" { GIL_Parser.SETUNION } | "-i-" { GIL_Parser.SETINTER } | "-d-" { GIL_Parser.SETDIFF } + | "--e--" | "-e-" { GIL_Parser.SETMEM } + | "--s--" | "-s-" { GIL_Parser.SETSUB } - | "--e--" { GIL_Parser.LSETMEM } - | "--s--" { GIL_Parser.LSETSUB } | "-{" { GIL_Parser.SETOPEN } | "}-" { GIL_Parser.SETCLOSE } (* Unary operators *) @@ -245,15 +251,9 @@ rule read = parse (* Logic assertions *) | "[[" { GIL_Parser.OASSERT } | "]]" { GIL_Parser.CASSERT } - | "/\\" { GIL_Parser.LAND } - | "\\/" { GIL_Parser.LOR } + | "/\\" { GIL_Parser.AND } + | "\\/" { GIL_Parser.OR } | "!" { GIL_Parser.LNOT } - | "==" { GIL_Parser.LEQUAL } - | "i<#" { GIL_Parser.ILLESSTHAN } - | "i<=#" { GIL_Parser.ILLESSTHANEQUAL } - | "<#" { GIL_Parser.FLLESSTHAN } - | "<=#" { GIL_Parser.FLLESSTHANEQUAL } - | "s<#" { GIL_Parser.LSLESSTHAN } | "is-int" { GIL_Parser.ISINT } (* Separating conjunction uses the same symbol as product, token TIMES *) (* Logic commands *) @@ -340,4 +340,4 @@ and read_init_data buf = { end -} \ No newline at end of file +} diff --git a/GillianCore/gil_parser/GIL_Parser.mly b/GillianCore/gil_parser/GIL_Parser.mly index b3053b10..9e8e7662 100644 --- a/GillianCore/gil_parser/GIL_Parser.mly +++ b/GillianCore/gil_parser/GIL_Parser.mly @@ -159,18 +159,8 @@ let normalised_lvar_r = Str.regexp "##NORMALISED_LVAR" (* Logic assertions *) %token OASSERT %token CASSERT -%token LAND -%token LOR %token LIMPLIES %token LNOT -%token LTRUE -%token LFALSE -%token LEQUAL -%token ILLESSTHAN -%token ILLESSTHANEQUAL -%token FLLESSTHAN -%token FLLESSTHANEQUAL -%token LSLESSTHAN %token ISINT %token LEMP (*%token LEXISTS *) @@ -235,8 +225,6 @@ let normalised_lvar_r = Str.regexp "##NORMALISED_LVAR" %token SETDIFF %token SETMEM %token SETSUB -%token LSETMEM -%token LSETSUB %token SETOPEN %token SETCLOSE (* EOF *) @@ -245,19 +233,13 @@ let normalised_lvar_r = Str.regexp "##NORMALISED_LVAR" (***** Precedence of operators *****) (* The later an operator is listed, the higher precedence it is given. *) (* Logic operators have lower precedence *) -%nonassoc DOT -%left LIMPLIES -%left LOR -%left LAND -%left separating_conjunction -%left magic_wand -%right LNOT -%right ISINT -%nonassoc LEQUAL ILLESSTHAN ILLESSTHANEQUAL FLLESSTHAN FLLESSTHANEQUAL LSLESSTHAN -%nonassoc SETMEM SETSUB LSETMEM LSETSUB (* Program operators have higher precedence.*) (* Based on JavaScript: https://developer.mozilla.org/en/docs/Web/JavaScript/Reference/Operators/Operator_Precedence *) +%nonassoc DOT +%left separating_conjunction +%left magic_wand +%left LIMPLIES %left OR %left AND %nonassoc EQ @@ -267,6 +249,9 @@ let normalised_lvar_r = Str.regexp "##NORMALISED_LVAR" %left FPLUS FMINUS IPLUS IMINUS %left FTIMES FDIV FMOD ITIMES IDIV IMOD M_POW %left M_ATAN2 STRCAT SETDIFF +%nonassoc SETMEM SETSUB +%right LNOT +%right ISINT %nonassoc binop_prec %nonassoc unop_prec @@ -1045,9 +1030,7 @@ lit_target: | NULL { Literal.Null } | EMPTY { Literal.Empty } | constant_target { Literal.Constant $1 } - | LTRUE | TRUE { Literal.Bool true } - | LFALSE | FALSE { Literal.Bool false } | FLOAT { Literal.Num $1 } | n = INTEGER { Literal.Int n } @@ -1068,31 +1051,23 @@ nop_target: ; binop_target: - | LEQUAL | EQ { BinOp.Equal } - | ILLESSTHAN | ILT { BinOp.ILessThan } - | ILLESSTHANEQUAL | ILE { BinOp.ILessThanEqual } | IPLUS { BinOp.IPlus } | IMINUS { BinOp.IMinus } | ITIMES { BinOp.ITimes } | IDIV { BinOp.IDiv } | IMOD { BinOp.IMod } - | FLLESSTHAN | FLT { BinOp.FLessThan } - | FLLESSTHANEQUAL | FLE { BinOp.FLessThanEqual } | FPLUS { BinOp.FPlus } | FMINUS { BinOp.FMinus } | FTIMES { BinOp.FTimes } | FDIV { BinOp.FDiv } | FMOD { BinOp.FMod } - | LSLESSTHAN | SLT { BinOp.StrLess } - | LAND | AND { BinOp.And } - | LOR | OR { BinOp.Or } | LIMPLIES { BinOp.Impl } | BITWISEAND { BinOp.BitwiseAnd } @@ -1111,9 +1086,7 @@ binop_target: | M_POW { BinOp.M_pow } | STRCAT { BinOp.StrCat } | SETDIFF { BinOp.SetDiff } - | LSETMEM | SETMEM { BinOp.SetMem } - | LSETSUB | SETSUB { BinOp.SetSub } ; diff --git a/GillianCore/smt/smt.ml b/GillianCore/smt/smt.ml index c518ffc6..eb38bbd2 100644 --- a/GillianCore/smt/smt.ml +++ b/GillianCore/smt/smt.ml @@ -974,7 +974,12 @@ let exec_sat' (fs : Expr.Set.t) (gamma : typenv) : sexp option = let exec_sat (fs : Expr.Set.t) (gamma : typenv) : sexp option = try exec_sat' fs gamma with UnexpectedSolverResponse _ as e -> - let msg = Fmt.str "SMT failure!\n%s\n" (Printexc.to_string e ^ "\n") in + let msg = + Fmt.str "SMT failure!@\n%s@\nExpressions: @\n%a" + (Printexc.to_string e ^ "\n") + Fmt.(list ~sep:(Fmt.any "@\n") Expr.pp) + (Expr.Set.elements fs) + in let () = L.print_to_all msg in exit 1 From 8d15c7dd4ab09054aba3662d8d823101144c5e15 Mon Sep 17 00:00:00 2001 From: N1ark Date: Wed, 25 Dec 2024 23:30:16 +0100 Subject: [PATCH 42/54] Appease CI? --- Gillian-C/runtime/logic_archi64.gil | 14 +++++++------- GillianCore/GIL_Syntax/BinOp.ml | 2 +- GillianCore/GIL_Syntax/UnOp.ml | 5 ++--- GillianCore/gil_parser/GIL_Parser.mly | 12 +++++++----- ppx_sat/test/out.expected | 4 ++-- wisl/runtime/wisl_pointer_arith.gil | 5 ++--- 6 files changed, 21 insertions(+), 21 deletions(-) diff --git a/Gillian-C/runtime/logic_archi64.gil b/Gillian-C/runtime/logic_archi64.gil index 44d492f8..20305ee7 100644 --- a/Gillian-C/runtime/logic_archi64.gil +++ b/Gillian-C/runtime/logic_archi64.gil @@ -2,33 +2,33 @@ pred i__is_ptr_to_0_opt (e: List): i__is_ptr_to_0(e), - e == {{ "long", 0i }}; + (e == {{ "long", 0i }}); pred i__is_ptr_opt (e: List): i__is_ptr(e), - e == {{ "long", 0i }}; + (e == {{ "long", 0i }}); pred i__is_ptr_to_int_opt (+e: List): i__ptr_to_0(e, #l) * (#l, 0i, "int32"; {{ "int", #i }}, "Freeable"), - e == {{ "long", 0i }}; + (e == {{ "long", 0i }}); pred i__is_ptr_to_float_opt (+e: List): i__ptr_to_0(e, #l) * (#l, 0i, "float32"; {{ "float", #i }}, "Freeable"), - e == {{ "long", 0i }}; + (e == {{ "long", 0i }}); pred i__is_ptr_to_long_opt (+e: List): i__ptr_to_0(e, #l) * (#l, 0i, "int64"; {{ "long", #i }}, "Freeable"), - e == {{ "long", 0i }}; + (e == {{ "long", 0i }}); pred i__is_ptr_to_single_opt (+e: List): i__ptr_to_0(e, #l) * (#l, 0i, "float32"; {{ "single", #i }}, "Freeable"), - e == {{ "long", 0i }}; + (e == {{ "long", 0i }}); pred i__malloced(+p: List, bytes: Int): i__ptr(p, #l, 0i) * (#l, -8i, "int64"; {{ "long", bytes }}, "Freeable") * - (#l; {{ -8i, bytes }}); \ No newline at end of file + (#l; {{ -8i, bytes }}); diff --git a/GillianCore/GIL_Syntax/BinOp.ml b/GillianCore/GIL_Syntax/BinOp.ml index 542b3c9a..d2a168df 100644 --- a/GillianCore/GIL_Syntax/BinOp.ml +++ b/GillianCore/GIL_Syntax/BinOp.ml @@ -62,7 +62,7 @@ let of_yojson = TypeDef__.binop_of_yojson let str (x : t) = match x with - | Equal -> "=" + | Equal -> "==" | ILessThan -> "i<" | ILessThanEqual -> "i<=" | IPlus -> "i+" diff --git a/GillianCore/GIL_Syntax/UnOp.ml b/GillianCore/GIL_Syntax/UnOp.ml index bcd55827..c5c0d09a 100644 --- a/GillianCore/GIL_Syntax/UnOp.ml +++ b/GillianCore/GIL_Syntax/UnOp.ml @@ -50,11 +50,10 @@ type t = TypeDef__.unop = | IsInt (** IsInt e <=> (e : float) /\ (e % 1. == 0) *) [@@deriving yojson, ord, eq] -let str (x : t) = - match x with +let str = function | IUnaryMinus -> "i-" | FUnaryMinus -> "-" - | Not -> "not" + | Not -> "!" | BitwiseNot -> "~" | M_isNaN -> "isNaN" | M_abs -> "m_abs" diff --git a/GillianCore/gil_parser/GIL_Parser.mly b/GillianCore/gil_parser/GIL_Parser.mly index 9e8e7662..9c26a147 100644 --- a/GillianCore/gil_parser/GIL_Parser.mly +++ b/GillianCore/gil_parser/GIL_Parser.mly @@ -701,9 +701,6 @@ g_assertion_target: (* types (type_pairs) *) | LTYPES; LBRACE; type_pairs = separated_list(COMMA, type_env_pair_target); RBRACE { [ Asrt.Types type_pairs ] } -(* (P) *) - | LBRACE; g_assertion_target; RBRACE - { $2 } (* (pure) *) | LBRACE; expr_target; RBRACE { [ Asrt.Pure $2 ] } @@ -811,7 +808,7 @@ g_pred_def_target: { defs } g_pred_facts_target: - FACTS; COLON; facts = separated_nonempty_list(AND, expr_target); SCOLON + FACTS; COLON; facts = expr_target; SCOLON { facts } g_pred_cost_target: @@ -845,7 +842,12 @@ g_pred_target: preds_with_no_paths := SS.add pred_name !preds_with_no_paths in let pred_normalised = !Config.previously_normalised in - let pred_facts = Option.value ~default:[] pred_facts in + let rec split_ands = function + | Expr.BinOp (e1, And, e2) -> (split_ands e1) @ (split_ands e2) + | e -> [e] + in + let pred_facts = Option.fold ~none:[] ~some:split_ands pred_facts in + Pred. { pred_name; diff --git a/ppx_sat/test/out.expected b/ppx_sat/test/out.expected index b77944da..d72d5ea5 100644 --- a/ppx_sat/test/out.expected +++ b/ppx_sat/test/out.expected @@ -1,13 +1,13 @@ [{pc: {pfs: [(! (x == 1i))]; gamma: (x: Int); - learned: [(1i i<=# x); (2i i<=# x)]; + learned: [(1i i<= x); (2i i<= x)]; learned_types: []}; value: 12}, {pc: {pfs: [(! (x == 1i))]; gamma: (x: Int); - learned: [(x i<# 1i); (x i<=# 0i)]; + learned: [(x i< 1i); (x i<= 0i)]; learned_types: []}; value: -1}] diff --git a/wisl/runtime/wisl_pointer_arith.gil b/wisl/runtime/wisl_pointer_arith.gil index cde86da2..a96b48f6 100644 --- a/wisl/runtime/wisl_pointer_arith.gil +++ b/wisl/runtime/wisl_pointer_arith.gil @@ -109,12 +109,12 @@ proc i__gt (el, er) { pred i__pred_add (+el, +er, out): types(el: List, er: Int) * (el == {{ #loc, #offset }}) * (out == {{ #loc, #offset i+ er }}), types(er: List, el: Int) * (er == {{ #loc, #offset}}) * (out == {{ #loc, #offset i+ el }}), - types(er: Int, el: Int) * (out == er i+ el); + types(er: Int, el: Int) * (out == (er i+ el)); (* i__pred_minus(x, y, z) is true if executing i__minus(x, y) would return z *) pred i__pred_minus (+el, +er, out): types(el: List, er: Int) * (el == {{ #loc, #offset }}) * (out == {{ #loc, #offset i- er }}), - types(er: Int, el: Int) * (out == el i- er); + types(er: Int, el: Int) * (out == (el i- er)); (* i__pred_lt(x, y, z) is true if executing i__lt(x, y) would return z *) pred i__pred_lt (+el, +er, out): @@ -135,4 +135,3 @@ pred i__pred_leq (+el, +er, out): pred i__pred_geq (+el, +er, out): types(el: List, er: List) * (el == {{ #locl, #offsetl }}) * (er == {{ #locr, #offsetr }}) * (#locr == #locl) * (out == (not (#offsetl i< #offsetr))), types(el: Int, er: Int) * (out == (not (el i< er))); - From cee19c456648fe15d7dc7ab09bf0e91327408382 Mon Sep 17 00:00:00 2001 From: N1ark Date: Thu, 26 Dec 2024 15:41:24 +0100 Subject: [PATCH 43/54] Fix operator precedence --- .../engine/concrete_semantics/CExprEval.ml | 160 +++++++------ GillianCore/gil_parser/GIL_Lexer.mll | 4 +- GillianCore/gil_parser/GIL_Parser.mly | 215 ++++++++++++------ 3 files changed, 235 insertions(+), 144 deletions(-) diff --git a/GillianCore/engine/concrete_semantics/CExprEval.ml b/GillianCore/engine/concrete_semantics/CExprEval.ml index 8e5b2193..95b0ce28 100644 --- a/GillianCore/engine/concrete_semantics/CExprEval.ml +++ b/GillianCore/engine/concrete_semantics/CExprEval.ml @@ -8,40 +8,82 @@ exception EvaluationError of string let evalerr msg = raise (EvaluationError (Fmt.str "Evaluation Error: %s" msg)) -let typeerr typ lit = - raise (TypeError (Fmt.str "Expected %s, got %a" typ Literal.pp lit)) +let typeerr ?msg typ lit = + raise + (TypeError + (match msg with + | Some msg -> Fmt.str "Expected %s, got %a (%s)" typ Literal.pp lit msg + | None -> Fmt.str "Expected %s, got %a" typ Literal.pp lit)) -let as_str = function +let as_str ?msg = function | Literal.String s -> s - | lit -> typeerr "string" lit + | lit -> typeerr ?msg "string" lit -let as_bool = function +let as_bool ?msg = function | Literal.Bool b -> b - | lit -> typeerr "boolean" lit + | lit -> typeerr ?msg "boolean" lit -let as_int = function +let as_int ?msg = function | Literal.Int i -> i - | lit -> typeerr "integer" lit + | lit -> typeerr ?msg "integer" lit -let as_num = function +let as_num ?msg = function | Literal.Num n -> n - | lit -> typeerr "number" lit + | lit -> typeerr ?msg "number" lit -let as_list = function +let as_list ?msg = function | Literal.LList l -> l - | lit -> typeerr "list" lit + | lit -> typeerr ?msg "list" lit -let unary_int_thing (lit : CVal.M.t) (f : Z.t -> Z.t) : CVal.M.t = - let num = as_int lit in +let unary_int_thing ?msg (lit : CVal.M.t) (f : Z.t -> Z.t) : CVal.M.t = + let num = as_int ?msg lit in let res = f num in Int res -let unary_num_thing (lit : CVal.M.t) (f : float -> float) : CVal.M.t = - let num = as_num lit in +let unary_num_thing ?msg (lit : CVal.M.t) (f : float -> float) : CVal.M.t = + let num = as_num ?msg lit in let res = f num in Num res +let binary_num_thing + ?msg + (lit1 : CVal.M.t) + (lit2 : CVal.M.t) + (f : float -> float -> float) = + let num1 = as_num ?msg lit1 in + let num2 = as_num ?msg lit2 in + Literal.Num (f num1 num2) + +let binary_int_thing + ?msg + (lit1 : CVal.M.t) + (lit2 : CVal.M.t) + (f : Z.t -> Z.t -> Z.t) = + let num1 = as_int ?msg lit1 in + let num2 = as_int ?msg lit2 in + Literal.Int (f num1 num2) + +let binary_int_bool_thing + ?msg + (lit1 : CVal.M.t) + (lit2 : CVal.M.t) + (f : Z.t -> Z.t -> bool) = + let num1 = as_int ?msg lit1 in + let num2 = as_int ?msg lit2 in + Literal.Bool (f num1 num2) + +let binary_num_bool_thing + ?msg + (lit1 : CVal.M.t) + (lit2 : CVal.M.t) + (f : float -> float -> bool) = + let num1 = as_num ?msg lit1 in + let num2 = as_num ?msg lit2 in + Literal.Bool (f num1 num2) + let evaluate_unop (op : UnOp.t) (lit : CVal.M.t) : CVal.M.t = + let unary_int_thing = unary_int_thing ~msg:(UnOp.str op) in + let unary_num_thing = unary_num_thing ~msg:(UnOp.str op) in match op with | Not -> let b = as_bool lit in @@ -58,22 +100,24 @@ let evaluate_unop (op : UnOp.t) (lit : CVal.M.t) : CVal.M.t = | M_exp -> unary_num_thing lit exp | M_floor -> unary_num_thing lit floor | M_log -> unary_num_thing lit log - | M_round -> ( - let n = as_num lit in - let sign = copysign 1.0 n in - match sign < 0.0 && n >= -0.5 with - | true -> Num (-0.0) - | _ -> - (* This complex rounding is needed for edge case in OCaml: 0.49999999999999994 *) - let round_nearest_lb = -.(2. ** 52.) in - let round_nearest_ub = 2. ** 52. in + | M_round -> + let f n = + let sign = copysign 1.0 n in + match sign < 0.0 && n >= -0.5 with + | true -> -0.0 + | _ -> + (* This complex rounding is needed for edge case in OCaml: 0.49999999999999994 *) + let round_nearest_lb = -.(2. ** 52.) in + let round_nearest_ub = 2. ** 52. in - let round_nearest t = - if t >= round_nearest_lb && t <= round_nearest_ub then - floor (t +. 0.49999999999999994) - else t - in - Num (round_nearest n)) + let round_nearest t = + if t >= round_nearest_lb && t <= round_nearest_ub then + floor (t +. 0.49999999999999994) + else t + in + round_nearest n + in + unary_num_thing lit f | M_sgn -> unary_num_thing lit (fun x -> copysign 1.0 x) | M_sin -> unary_num_thing lit sin | M_sqrt -> unary_num_thing lit sqrt @@ -126,36 +170,6 @@ let evaluate_unop (op : UnOp.t) (lit : CVal.M.t) : CVal.M.t = let x = as_num lit in Bool (is_int x) -let binary_num_thing - (lit1 : CVal.M.t) - (lit2 : CVal.M.t) - (f : float -> float -> float) = - let num1 = as_num lit1 in - let num2 = as_num lit2 in - Literal.Num (f num1 num2) - -let binary_int_thing (lit1 : CVal.M.t) (lit2 : CVal.M.t) (f : Z.t -> Z.t -> Z.t) - = - let num1 = as_int lit1 in - let num2 = as_int lit2 in - Literal.Int (f num1 num2) - -let binary_int_bool_thing - (lit1 : CVal.M.t) - (lit2 : CVal.M.t) - (f : Z.t -> Z.t -> bool) = - let num1 = as_int lit1 in - let num2 = as_int lit2 in - Literal.Bool (f num1 num2) - -let binary_num_bool_thing - (lit1 : CVal.M.t) - (lit2 : CVal.M.t) - (f : float -> float -> bool) = - let num1 = as_num lit1 in - let num2 = as_num lit2 in - Literal.Bool (f num1 num2) - let rec evaluate_binop (store : CStore.t) (op : BinOp.t) @@ -163,19 +177,23 @@ let rec evaluate_binop (e2 : Expr.t) : CVal.M.t = let ee = evaluate_expr store in let lit1 = ee e1 in + let binary_int_bool_thing = binary_int_bool_thing ~msg:(BinOp.str op) in + let binary_num_bool_thing = binary_num_bool_thing ~msg:(BinOp.str op) in + let binary_int_thing = binary_int_thing ~msg:(BinOp.str op) in + let binary_num_thing = binary_num_thing ~msg:(BinOp.str op) in match op with | Impl -> ee (BinOp (UnOp (Not, Expr.Lit lit1), Or, e2)) | And -> - let b1 = as_bool lit1 in + let b1 = as_bool ~msg:"And" lit1 in if not b1 then Bool false else - let b2 = as_bool @@ ee e2 in + let b2 = as_bool ~msg:"And" @@ ee e2 in Bool b2 | Or -> - let b1 = as_bool lit1 in + let b1 = as_bool ~msg:"Or" lit1 in if b1 then Bool true else - let b2 = as_bool @@ ee e2 in + let b2 = as_bool ~msg:"Or" @@ ee e2 in Bool b2 | _ -> ( let lit2 = ee e2 in @@ -200,23 +218,23 @@ let rec evaluate_binop | Nono, Nono -> Bool true | _, _ -> Bool false) | LstNth -> ( - let list = as_list lit1 in + let list = as_list ~msg:"LstNth" lit1 in match lit2 with | Int n -> List.nth list (Z.to_int n) | Num n when is_int n -> List.nth list (int_of_float n) | Num -0. -> List.nth list 0 - | _ -> typeerr "integer or number" lit2) + | _ -> typeerr ~msg:"LstNth" "integer or number" lit2) | LstRepeat -> - let n = as_int lit2 in + let n = as_int ~msg:"LstRepeat" lit2 in let n = Z.to_int n in let elements = List.init n (fun _ -> lit1) in LList elements | StrNth -> ( - let s = as_str lit1 in + let s = as_str ~msg:"StrNth" lit1 in match lit2 with | Num n when is_int n -> String (String.make 1 s.[int_of_float n]) | Num -0. -> String (String.make 1 s.[0]) - | _ -> typeerr "number" lit2) + | _ -> typeerr ~msg:"StrNth" "number" lit2) | ILessThan -> binary_int_bool_thing lit1 lit2 ( < ) | FLessThan -> binary_num_bool_thing lit1 lit2 ( < ) | StrLess -> @@ -267,7 +285,7 @@ let rec evaluate_binop and evaluate_nop (nop : NOp.t) (ll : Literal.t list) : CVal.M.t = match nop with - | LstCat -> LList (List.concat_map as_list ll) + | LstCat -> LList (List.concat_map (as_list ~msg:"LstCat") ll) | SetInter | SetUnion -> raise (Exceptions.Unsupported "Concrete evaluate_nop: set operators") diff --git a/GillianCore/gil_parser/GIL_Lexer.mll b/GillianCore/gil_parser/GIL_Lexer.mll index cbe52d9c..1b3937de 100644 --- a/GillianCore/gil_parser/GIL_Lexer.mll +++ b/GillianCore/gil_parser/GIL_Lexer.mll @@ -251,8 +251,8 @@ rule read = parse (* Logic assertions *) | "[[" { GIL_Parser.OASSERT } | "]]" { GIL_Parser.CASSERT } - | "/\\" { GIL_Parser.AND } - | "\\/" { GIL_Parser.OR } + | "/\\" { GIL_Parser.LAND } + | "\\/" { GIL_Parser.LOR } | "!" { GIL_Parser.LNOT } | "is-int" { GIL_Parser.ISINT } (* Separating conjunction uses the same symbol as product, token TIMES *) diff --git a/GillianCore/gil_parser/GIL_Parser.mly b/GillianCore/gil_parser/GIL_Parser.mly index 9c26a147..a59c1572 100644 --- a/GillianCore/gil_parser/GIL_Parser.mly +++ b/GillianCore/gil_parser/GIL_Parser.mly @@ -48,6 +48,8 @@ let normalised_lvar_r = Str.regexp "##NORMALISED_LVAR" (* Binary operators *) %token EQ %token WAND +%token LAND +%token LOR %token FLT %token FGT @@ -238,10 +240,9 @@ let normalised_lvar_r = Str.regexp "##NORMALISED_LVAR" https://developer.mozilla.org/en/docs/Web/JavaScript/Reference/Operators/Operator_Precedence *) %nonassoc DOT %left separating_conjunction -%left magic_wand %left LIMPLIES -%left OR -%left AND +%left OR, LOR +%left AND, LAND %nonassoc EQ %nonassoc FLT FLE FGT FGE ILT ILE IGT IGE SLT %left LEFTSHIFT SIGNEDRIGHTSHIFT UNSIGNEDRIGHTSHIFT LEFTSHIFTL SIGNEDRIGHTSHIFTL UNSIGNEDRIGHTSHIFTL @@ -250,18 +251,12 @@ let normalised_lvar_r = Str.regexp "##NORMALISED_LVAR" %left FTIMES FDIV FMOD ITIMES IDIV IMOD M_POW %left M_ATAN2 STRCAT SETDIFF %nonassoc SETMEM SETSUB -%right LNOT -%right ISINT - -%nonassoc binop_prec -%nonassoc unop_prec (***** Types and entry points *****) %type lit_target %type type_target %type constant_target %type unop_target -%type binop_target %type nop_target %type <(Annot.t, string) Prog.t * Yojson.Safe.t> gmain_target @@ -353,7 +348,7 @@ pred_head_target: (********* Expressions *********) (*******************************) -expr_target: +atomic_expr_target: (* literal *) | lit=lit_target { Expr.Lit lit } (* Logic variable *) @@ -365,26 +360,6 @@ expr_target: (* Program variable (including the special variable "ret") *) | pvar = program_variable_target { pvar } -(* e binop e *) - | e1=expr_target; bop=binop_target; e2=expr_target - { Expr.BinOp (e1, bop, e2) } %prec binop_prec - | e1=expr_target; FGT; e2=expr_target - { Expr.BinOp (e2, FLessThan, e1) } - | e1=expr_target; FGE; e2=expr_target - { Expr.BinOp (e2, FLessThanEqual, e1) } - | e1=expr_target; IGT; e2=expr_target - { Expr.BinOp (e2, ILessThan, e1) } - | e1=expr_target; IGE; e2=expr_target - { Expr.BinOp (e2, ILessThanEqual, e1) } -(* unop e *) - | uop=unop_target; e=expr_target - { Expr.UnOp (uop, e) } %prec unop_prec -(* - e *) -(* Unary negation has the same precedence as logical not, not as binary negation. *) - | IMINUS; e=expr_target - { Expr.UnOp (IUnaryMinus, e) } %prec unop_prec - | FMINUS; e=expr_target - { Expr.UnOp (FUnaryMinus, e) } %prec unop_prec (* {{ e, ..., e }} *) | LSTOPEN; exprlist = separated_nonempty_list(COMMA, expr_target); LSTCLOSE { Expr.EList exprlist } @@ -423,6 +398,138 @@ expr_target: { Expr.ForAll (vars, e) } ; +unary_expr: + | atomic_expr_target { $1 } +(* unop e *) + | uop=unop_target; e=unary_expr + { Expr.UnOp (uop, e) } +(* - e *) + | IMINUS; e=unary_expr + { Expr.UnOp (IUnaryMinus, e) } + | FMINUS; e=unary_expr + { Expr.UnOp (FUnaryMinus, e) } + +set_op_expr: + | unary_expr { $1 } + | e1 = set_op_expr; SETMEM; e2 = unary_expr + { Expr.BinOp (e1, SetMem, e2) } + | e1 = set_op_expr; SETSUB; e2 = unary_expr + { Expr.BinOp (e1, SetSub, e2) } + +unary_op_expr: + | set_op_expr { $1 } + | e1 = unary_op_expr; M_ATAN2; e2 = set_op_expr + { Expr.BinOp (e1, M_atan2, e2) } + | e1 = unary_op_expr; STRCAT; e2 = set_op_expr + { Expr.BinOp (e1, StrCat, e2) } + | e1 = unary_op_expr; SETDIFF; e2 = set_op_expr + { Expr.BinOp (e1, SetDiff, e2) } + +muldiv_expr: + | unary_op_expr { $1 } + | e1 = muldiv_expr; FTIMES; e2 = unary_op_expr + { Expr.BinOp (e1, FTimes, e2) } + | e1 = muldiv_expr; FDIV; e2 = unary_op_expr + { Expr.BinOp (e1, FDiv, e2) } + | e1 = muldiv_expr; FMOD; e2 = unary_op_expr + { Expr.BinOp (e1, FMod, e2) } + | e1 = muldiv_expr; ITIMES; e2 = unary_op_expr + { Expr.BinOp (e1, ITimes, e2) } + | e1 = muldiv_expr; IDIV; e2 = unary_op_expr + { Expr.BinOp (e1, IDiv, e2) } + | e1 = muldiv_expr; IMOD; e2 = unary_op_expr + { Expr.BinOp (e1, IMod, e2) } + | e1 = muldiv_expr; M_POW; e2 = unary_op_expr + { Expr.BinOp (e1, M_pow, e2) } + +addsub_expr: + | muldiv_expr { $1 } + | e1 = addsub_expr; FPLUS; e2 = muldiv_expr + { Expr.BinOp (e1, FPlus, e2) } + | e1 = addsub_expr; FMINUS; e2 = muldiv_expr + { Expr.BinOp (e1, FMinus, e2) } + | e1 = addsub_expr; IPLUS; e2 = muldiv_expr + { Expr.BinOp (e1, IPlus, e2) } + | e1 = addsub_expr; IMINUS; e2 = muldiv_expr + { Expr.BinOp (e1, IMinus, e2) } + +binary_op_expr: + | addsub_expr { $1 } + | e1 = binary_op_expr; BITWISEOR; e2 = addsub_expr + { Expr.BinOp (e1, BitwiseOr, e2) } + | e1 = binary_op_expr; BITWISEXOR; e2 = addsub_expr + { Expr.BinOp (e1, BitwiseXor, e2) } + | e1 = binary_op_expr; BITWISEAND; e2 = addsub_expr + { Expr.BinOp (e1, BitwiseAnd, e2) } + | e1 = binary_op_expr; BITWISEXORL; e2 = addsub_expr + { Expr.BinOp (e1, BitwiseXorL, e2) } + | e1 = binary_op_expr; BITWISEORL; e2 = addsub_expr + { Expr.BinOp (e1, BitwiseOrL, e2) } + | e1 = binary_op_expr; BITWISEANDL; e2 = addsub_expr + { Expr.BinOp (e1, BitwiseAndL, e2) } + +shift_expr: + | binary_op_expr { $1 } + | e1 = shift_expr; LEFTSHIFT; e2 = binary_op_expr + { Expr.BinOp (e1, LeftShift, e2) } + | e1 = shift_expr; SIGNEDRIGHTSHIFT; e2 = binary_op_expr + { Expr.BinOp (e1, SignedRightShift, e2) } + | e1 = shift_expr; UNSIGNEDRIGHTSHIFT; e2 = binary_op_expr + { Expr.BinOp (e1, UnsignedRightShift, e2) } + | e1 = shift_expr; LEFTSHIFTL; e2 = binary_op_expr + { Expr.BinOp (e1, LeftShiftL, e2) } + | e1 = shift_expr; SIGNEDRIGHTSHIFTL; e2 = binary_op_expr + { Expr.BinOp (e1, SignedRightShiftL, e2) } + | e1 = shift_expr; UNSIGNEDRIGHTSHIFTL; e2 = binary_op_expr + { Expr.BinOp (e1, UnsignedRightShiftL, e2) } + +comparison_expr: + | shift_expr { $1 } + | e1 = comparison_expr; ILT; e2 = shift_expr + { Expr.BinOp (e1, ILessThan, e2) } + | e1 = comparison_expr; ILE; e2 = shift_expr + { Expr.BinOp (e1, ILessThanEqual, e2) } + | e1 = comparison_expr; IGT; e2 = shift_expr + { Expr.BinOp (e2, ILessThan, e1) } + | e1 = comparison_expr; IGE; e2 = shift_expr + { Expr.BinOp (e2, ILessThanEqual, e1) } + | e1 = comparison_expr; FLT; e2 = shift_expr + { Expr.BinOp (e1, FLessThan, e2) } + | e1 = comparison_expr; FLE; e2 = shift_expr + { Expr.BinOp (e1, FLessThanEqual, e2) } + | e1 = comparison_expr; FGT; e2 = shift_expr + { Expr.BinOp (e2, FLessThan, e1) } + | e1 = comparison_expr; FGE; e2 = shift_expr + { Expr.BinOp (e2, FLessThanEqual, e1) } + | e1 = comparison_expr; SLT; e2 = shift_expr + { Expr.BinOp (e1, StrLess, e2) } + +eq_expr: + | comparison_expr { $1 } + | e1 = eq_expr; EQ; e2 = comparison_expr + { Expr.BinOp (e1, Equal, e2) } + +and_expr: + | eq_expr { $1 } + | e1 = and_expr; AND; e2 = eq_expr + | e1 = and_expr; LAND; e2 = eq_expr + { Expr.BinOp (e1, And, e2) } + +or_expr: + | and_expr { $1 } + | e1 = or_expr; OR; e2 = and_expr + | e1 = or_expr; LOR; e2 = and_expr + { Expr.BinOp (e1, Or, e2) } + +implication_expr: + | or_expr { $1 } + | e1 = implication_expr; LIMPLIES; e2 = or_expr + { Expr.BinOp (e1, Impl, e2) } + +expr_target: + implication_expr { $1 } +; + top_level_expr_target: e = expr_target; EOF { e } ; @@ -680,12 +787,18 @@ predicate_call: { (name, params) } g_assertion_target: +(* (pure) /\ (pure) *) + | LBRACE; e1 = expr_target; RBRACE; LAND; LBRACE; e2 = expr_target; RBRACE + { [ Asrt.Pure (BinOp (e1, And, e2)) ] } +(* (pure) \/ (pure) *) + | LBRACE; e1 = expr_target; RBRACE; LOR; LBRACE; e2 = expr_target; RBRACE + { [ Asrt.Pure (BinOp (e1, Or, e2)) ] } (* P * Q *) (* The precedence of the separating conjunction is not the same as the arithmetic product *) | left_ass=g_assertion_target; FTIMES; right_ass=g_assertion_target { left_ass @ right_ass } %prec separating_conjunction | lhs = predicate_call; WAND; rhs = predicate_call - { [ Asrt.Wand {lhs; rhs } ] } %prec magic_wand + { [ Asrt.Wand {lhs; rhs } ] } (* (es; es) *) | FLT; v=VAR; FGT; LBRACE; es1=separated_list(COMMA, expr_target); SCOLON; es2=separated_list(COMMA, expr_target); RBRACE { [ Asrt.CorePred (v, es1, es2) ] } @@ -1052,46 +1165,6 @@ nop_target: | LSTCAT { NOp.LstCat } ; -binop_target: - | EQ { BinOp.Equal } - | ILT { BinOp.ILessThan } - | ILE { BinOp.ILessThanEqual } - | IPLUS { BinOp.IPlus } - | IMINUS { BinOp.IMinus } - | ITIMES { BinOp.ITimes } - | IDIV { BinOp.IDiv } - | IMOD { BinOp.IMod } - | FLT { BinOp.FLessThan } - | FLE { BinOp.FLessThanEqual } - | FPLUS { BinOp.FPlus } - | FMINUS { BinOp.FMinus } - | FTIMES { BinOp.FTimes } - | FDIV { BinOp.FDiv } - | FMOD { BinOp.FMod } - | SLT { BinOp.StrLess } - | AND { BinOp.And } - | OR { BinOp.Or } - | LIMPLIES { BinOp.Impl } - | BITWISEAND { BinOp.BitwiseAnd } - | BITWISEOR { BinOp.BitwiseOr} - | BITWISEXOR { BinOp.BitwiseXor } - | LEFTSHIFT { BinOp.LeftShift } - | SIGNEDRIGHTSHIFT { BinOp.SignedRightShift } - | UNSIGNEDRIGHTSHIFT { BinOp.UnsignedRightShift } - | BITWISEANDL { BinOp.BitwiseAndL } - | BITWISEORL { BinOp.BitwiseOrL } - | BITWISEXORL { BinOp.BitwiseXorL } - | LEFTSHIFTL { BinOp.LeftShiftL } - | SIGNEDRIGHTSHIFTL { BinOp.SignedRightShiftL } - | UNSIGNEDRIGHTSHIFTL { BinOp.UnsignedRightShiftL } - | M_ATAN2 { BinOp.M_atan2 } - | M_POW { BinOp.M_pow } - | STRCAT { BinOp.StrCat } - | SETDIFF { BinOp.SetDiff } - | SETMEM { BinOp.SetMem } - | SETSUB { BinOp.SetSub } -; - unop_target: (* Unary minus defined in (l)expr_target *) | LNOT From d5ee07cec65167dd5463e9e212701f4992b1a5ae Mon Sep 17 00:00:00 2001 From: N1ark Date: Fri, 27 Dec 2024 20:54:41 +0100 Subject: [PATCH 44/54] Use Sacha's new `resolve_expr_to_location` Co-Authored-By: Sacha Ayoun --- GillianCore/engine/FOLogic/Reduction.ml | 127 ++++++++++++------------ 1 file changed, 64 insertions(+), 63 deletions(-) diff --git a/GillianCore/engine/FOLogic/Reduction.ml b/GillianCore/engine/FOLogic/Reduction.ml index 7e0330de..ffb56ab0 100644 --- a/GillianCore/engine/FOLogic/Reduction.ml +++ b/GillianCore/engine/FOLogic/Reduction.ml @@ -2412,76 +2412,77 @@ and substitute_for_list_length (pfs : PFS.t) (le : Expr.t) : Expr.t = let resolve_expr_to_location (pfs : PFS.t) (gamma : Type_env.t) (e : Expr.t) : string option = - let max_fuel = 5 in + let max_fuel = 10 in + + let loc_name = function + | Expr.ALoc loc | Lit (Loc loc) -> Some loc + | _ -> None + in let rec resolve_expr_to_location_aux (fuel : int) (tried : Expr.Set.t) (to_try : Expr.t list) : string option = + let open Syntaxes.Option in + L.tmi (fun m -> m "to_try: %a" (Fmt.Dump.list Expr.pp) to_try); + let* () = if fuel <= 0 then None else Some () in + let* e, rest = + match to_try with + | [] -> None + | e :: rest -> Some (e, rest) + in let f = resolve_expr_to_location_aux (fuel - 1) in - match fuel = 0 with - | true -> None - | false -> ( - match to_try with - | [] -> None - | e :: _rest -> ( - match e with - | Lit (Loc loc) | ALoc loc -> Some loc - | _ -> ( - let equal_e = get_equal_expressions pfs e in - let equal_e = - equal_e @ List.map (reduce_lexpr ~pfs ~gamma) equal_e - in - let ores = - List.find_opt - (fun x -> - match x with - | Expr.ALoc _ | Lit (Loc _) -> true - | _ -> false) - equal_e - in - match ores with - | Some (ALoc loc) | Some (Lit (Loc loc)) -> Some loc - | _ -> ( - let lvars_e = - List.map - (fun x -> Expr.LVar x) - (Containers.SS.elements (Expr.lvars e)) - in - let found_subst = - List.map - (fun e -> (e, get_equal_expressions pfs e)) - lvars_e - in - let found_subst = - List.filter_map - (fun (e, es) -> - match es with - | [] -> None - | es :: _ -> Some (e, es)) - found_subst - in - let subst_e = - List.fold_left - (fun (e : Expr.t) (e_to, e_with) -> - Expr.subst_expr_for_expr ~to_subst:e_to - ~subst_with:e_with e) - e found_subst - in - let subst_e = reduce_lexpr ~pfs ~gamma subst_e in - match subst_e with - | ALoc loc | Lit (Loc loc) -> Some loc - | _ -> - let new_tried = Expr.Set.add e tried in - let new_to_try = equal_e @ [ subst_e ] in - let new_to_try = - List.filter - (fun e -> not (Expr.Set.mem e new_tried)) - new_to_try - in - f new_tried new_to_try)))) + (* If e is a loc name, we return it *) + let/ () = loc_name e in + let equal_e = get_equal_expressions pfs e in + let equal_e = equal_e @ List.map (reduce_lexpr ~pfs ~gamma) equal_e in + (* If we find a loc in there, we return it *) + let/ () = List.find_map loc_name equal_e in + (* We actually want to try all possible substs! *) + let all_lvars = Containers.SS.elements (Expr.lvars e) in + let subst_for_each_lvar = + List.map + (fun x -> + let e = Expr.LVar x in + let with_eq = + List.map (fun eq -> (e, eq)) (get_equal_expressions pfs e) + in + (e, e) :: with_eq) + all_lvars + in + L.tmi (fun m -> + m "subst_for_each_lvar: %a" + (Fmt.Dump.list (Fmt.Dump.list (Fmt.Dump.pair Expr.pp Expr.pp))) + subst_for_each_lvar); + let found_substs = + List.fold_left + (fun l1 l2 -> List_utils.cross_product l1 l2 (fun l x -> x :: l)) + [ [] ] subst_for_each_lvar + in + L.tmi (fun m -> + m "found_substs: %a" + (Fmt.Dump.list (Fmt.Dump.list (Fmt.Dump.pair Expr.pp Expr.pp))) + found_substs); + (* lvar and substs is a list [ (ei, esi) ] where for each ei, esi is a list of equal expressions. + We are going to build the product of each esi to obtain *) + let subst_es = + List.map + (List.fold_left + (fun (e : Expr.t) (e_to, e_with) -> + Expr.subst_expr_for_expr ~to_subst:e_to ~subst_with:e_with e) + e) + found_substs + in + L.tmi (fun m -> m "subst_es: %a" (Fmt.Dump.list Expr.pp) subst_es); + let subst_es = List.map (reduce_lexpr ~pfs ~gamma) subst_es in + let/ () = List.find_map loc_name subst_es in + let new_tried = Expr.Set.add e tried in + let new_to_try = rest @ equal_e @ subst_es in + let new_to_try = + List.filter (fun e -> not (Expr.Set.mem e new_tried)) new_to_try + in + f new_tried new_to_try in - resolve_expr_to_location_aux max_fuel Expr.Set.empty [ e ] let rec reduce_formula_loop From 9b4f431853152064a535c3d53acaa642fdd26f13 Mon Sep 17 00:00:00 2001 From: N1ark Date: Sun, 29 Dec 2024 00:55:23 +0100 Subject: [PATCH 45/54] Collapse reductions (wow) --- GillianCore/GIL_Syntax/Expr.ml | 24 +- GillianCore/engine/FOLogic/Reduction.ml | 2486 ++++++++--------- GillianCore/engine/FOLogic/Reduction.mli | 2 +- GillianCore/engine/FOLogic/Simplifications.ml | 2 +- 4 files changed, 1101 insertions(+), 1413 deletions(-) diff --git a/GillianCore/GIL_Syntax/Expr.ml b/GillianCore/GIL_Syntax/Expr.ml index 01ea4653..656ba27f 100644 --- a/GillianCore/GIL_Syntax/Expr.ml +++ b/GillianCore/GIL_Syntax/Expr.ml @@ -114,21 +114,15 @@ let list_cons el r = list_cat sgl r let list el = - if - List.for_all - (function - | Lit _ -> true - | _ -> false) - el - then - Lit - (LList - (List.map - (function - | Lit l -> l - | _ -> assert false) - el)) - else EList el + let rec aux l = + match l with + | [] -> Some [] + | Lit l :: r -> Option.map (fun x -> l :: x) (aux r) + | _ -> None + in + match aux el with + | Some l -> Lit (LList l) + | None -> EList el let fmod a b = match (a, b) with diff --git a/GillianCore/engine/FOLogic/Reduction.ml b/GillianCore/engine/FOLogic/Reduction.ml index b8d4f2c4..de287cfa 100644 --- a/GillianCore/engine/FOLogic/Reduction.ml +++ b/GillianCore/engine/FOLogic/Reduction.ml @@ -346,17 +346,17 @@ let rec get_nth_of_list (pfs : PFS.t) (lst : Expr.t) (idx : int) : Expr.t option (* Finding the nth element of a list *) let get_head_and_tail_of_list ~pfs lst = - let rec loop (pfs : PFS.t) (unacceptable : Expr.Set.t) (lst : Expr.t) : + let rec loop (pfs : PFS.t) (checked : Expr.Set.t) (lst : Expr.t) : (Expr.t * Expr.t) option = - let loop = loop pfs (Expr.Set.add lst unacceptable) in + let loop = loop pfs (Expr.Set.add lst checked) in match lst with (* Nothing can be done for variables *) (* FIXME: This function is suboptimal *) | PVar _ -> None | LVar _ -> ( - let ole = get_equal_expressions pfs lst in let ole = - List.filter (fun x -> not (Expr.Set.mem x unacceptable)) ole + get_equal_expressions pfs lst + |> List.filter (fun x -> not (Expr.Set.mem x checked)) in match ole with | [] -> None @@ -364,14 +364,14 @@ let get_head_and_tail_of_list ~pfs lst = L.verbose (fun fmt -> fmt "LE: %a\n\n" Expr.pp le); loop le) (* Base lists of literals and logical expressions *) - | Lit (LList l) -> - if l = [] then None else Some (Lit (List.hd l), Lit (LList (List.tl l))) - | EList l -> if l = [] then None else Some (List.hd l, EList (List.tl l)) + | Lit (LList []) -> None + | Lit (LList (hd :: tl)) -> Some (Lit hd, Lit (LList tl)) + | EList [] -> None + | EList (hd :: tl) -> Some (hd, EList tl) | NOp (LstCat, lel :: ler) -> - Option.value ~default:None - (Option.map - (fun (hd, tl) -> Some (hd, Expr.NOp (LstCat, tl :: ler))) - (loop lel)) + Option.map + (fun (hd, tl) -> (hd, Expr.NOp (LstCat, tl :: ler))) + (loop lel) | _ -> None in loop pfs Expr.Set.empty lst @@ -600,8 +600,7 @@ let prefix_catch pfs (x : Expr.t) (y : string) = match x with | NOp (LstCat, x) -> PFS.exists - (fun pf -> - match pf with + (function | BinOp (NOp (LstCat, lx), Equal, NOp (LstCat, LVar y' :: _)) when y = y' -> ( match List_utils.list_sub lx 0 (List.length x) with @@ -611,8 +610,7 @@ let prefix_catch pfs (x : Expr.t) (y : string) = pfs | LVar x -> PFS.exists - (fun pf -> - match pf with + (function | BinOp (NOp (LstCat, LVar x' :: _), Equal, NOp (LstCat, LVar y' :: _)) -> (x' = x && y = y') || (y' = x && x' = y) | _ -> false) @@ -735,16 +733,13 @@ module Canonical = struct (fun e vr (restl, restr) -> match Expr.Map.find_opt e restl with | None -> (restl, restr) - | Some vl -> ( - match vl = vr with - | true -> (Expr.Map.remove e restl, Expr.Map.remove e restr) - | false -> - if vl > vr then - ( Expr.Map.add e (P.sub vl vr) restl, - Expr.Map.remove e restr ) - else - ( Expr.Map.remove e restl, - Expr.Map.add e (P.sub vr vl) restr ))) + | Some vl -> + if vl = vr then + (Expr.Map.remove e restl, Expr.Map.remove e restr) + else if vl > vr then + (Expr.Map.add e (P.sub vl vr) restl, Expr.Map.remove e restr) + else + (Expr.Map.remove e restl, Expr.Map.add e (P.sub vr vl) restr)) cr.symb (cl.symb, cr.symb) in let cl, cr = ({ conc = nl; symb = restl }, { conc = nr; symb = restr }) in @@ -917,499 +912,152 @@ and reduce_lexpr_loop let result : Expr.t = match le with - | Lit _ -> le - | BinOp (BinOp (a, FTimes, _), FMod, c) - when Expr.equal a c || Expr.equal a c -> Expr.num 0. - | BinOp (x, FTimes, BinOp (y, FDiv, z)) when x = z -> f y - | BinOp (BinOp (x, FDiv, y), FTimes, z) when y = z -> f x - | BinOp (Lit (LList ll), Equal, Lit (LList lr)) -> Lit (Bool (ll = lr)) - | BinOp (left, Impl, right) -> ( - let left = f left in - match Expr.as_boolean_expr left with - | None -> BinOp (left, Impl, f right) - | Some (Lit (Bool true), _) -> f right - | Some (Lit (Bool false), _) -> Lit (Bool true) - | Some (left_f, _) -> - let pfs_with_left = - let copy = PFS.copy pfs in - let () = PFS.extend copy left_f in - copy - in - let right = - reduce_lexpr_loop ~matching ~reduce_lvars pfs_with_left gamma - right - in - BinOp (left, Impl, right)) - | BinOp (EList le, Equal, Lit (LList ll)) - | BinOp (Lit (LList ll), Equal, EList le) -> - if List.length ll <> List.length le then Lit (Bool false) - else if ll = [] then Lit (Bool true) - else - let eqs = List.map2 (fun x y -> Expr.BinOp (x, Equal, Lit y)) le ll in - let conj = - List.fold_left - (fun ac x -> Expr.BinOp (ac, And, x)) - (List.hd eqs) (List.tl eqs) - in - f conj - | BinOp (EList ll, Equal, EList lr) -> - if List.length ll <> List.length lr then Lit (Bool false) - else if ll = [] then Lit (Bool true) - else - let eqs = List.map2 (fun x y -> Expr.BinOp (x, Equal, y)) ll lr in - let conj = - List.fold_left - (fun ac x -> Expr.BinOp (ac, And, x)) - (List.hd eqs) (List.tl eqs) - in - f conj - | BinOp (ALoc x, Equal, ALoc y) when not matching -> Lit (Bool (x = y)) - | LVar x when reduce_lvars -> ( - let equals = get_equal_expressions pfs (LVar x) in - let lit_equals = - List.filter - (fun eq -> - match eq with - | Expr.Lit _ -> true - | _ -> false) - equals - in - match lit_equals with - | [] -> LVar x - | Lit l :: _ -> Lit l - | _ -> - raise - (Exceptions.Impossible - "reduce_lexpr: LVar x when reducing lvars: guaranteed by \ - match/filter")) - (* Base lists *) - | EList les -> ( - let fles = List.map f les in - let all_literals = - let rec loop l = - match l with - | [] -> Some [] - | Expr.Lit l :: r -> Option.map (fun x -> l :: x) (loop r) - | _ -> None - in - loop fles + (* ------------------------- + Base cases + ------------------------- *) + | Lit _ | PVar _ | ALoc _ -> le + (* ------------------------- + LVar + ------------------------- *) + | LVar _ when reduce_lvars -> + get_equal_expressions pfs le + |> List.find_opt (function + | Expr.Lit _ -> true + | _ -> false) + |> Option.value ~default:le + | LVar _ -> le + (* ------------------------- + EList + ------------------------- *) + | EList les -> List.map f les |> Expr.list + (* ------------------------- + ESet + ------------------------- *) + | ESet les -> ESet (Expr.Set.elements @@ Expr.Set.of_list @@ List.map f les) + (* ------------------------- + ForAll + Exists + ------------------------- *) + (* Given: l = [l0, l1, ..., ln] + Before: ∀ i∈ℕ. i<0 ∨ len(l)<=i ∨ l[i]==e + After: l==[e, e, ..., e] *) + | ForAll + ( [ (x, Some IntType) ], + BinOp + ( BinOp + ( BinOp (LVar a, ILessThan, Lit (Int z)), + Or, + BinOp (Lit (Int len), ILessThanEqual, LVar b) ), + Or, + BinOp (BinOp (EList c, LstNth, LVar d), Equal, e) ) ) + when Z.equal z Z.zero && String.equal x a && String.equal a b + && String.equal b d + && Int.equal (List.compare_length_with c (Z.to_int len)) 0 -> + let rhs = Expr.EList (List_utils.make (Z.to_int len) e) in + BinOp (EList c, Equal, rhs) + (* Given: l = [l0, l1, ..., ln] + Before: ∀ i∈ℕ. (0<=i ∧ i l[i]==k + After: l0=k ∧ l1=k ∧ ... ∧ ln=k *) + | ForAll + ( [ (i, Some IntType) ], + BinOp + ( BinOp + ( BinOp (Lit (Int z), ILessThanEqual, LVar i'), + And, + BinOp (LVar i'', ILessThan, UnOp (LstLen, (EList ll as l))) ), + Impl, + BinOp (BinOp (l', LstNth, LVar i'''), Equal, k) ) ) + when Z.(equal z zero) + && i = i' && i' = i'' && i'' = i''' && Expr.equal l l' -> + List.map (Expr.Infix.( == ) k) ll |> Expr.conjunct + | ForAll (bt, e) | Exists (bt, e) -> ( + (* We create a new pfs and gamma where: + - All shadowed variables are substituted with a fresh variable + - The gamma has been updated with the types given in the binder *) + let new_gamma = Type_env.copy gamma in + let new_pfs = PFS.copy pfs in + let subst_bindings = List.map (fun (x, _) -> (x, LVar.alloc ())) bt in + let subst = + SVal.SESubst.init + (List.map (fun (x, y) -> (Expr.LVar x, Expr.LVar y)) subst_bindings) in - match all_literals with - | Some lits -> Expr.Lit (LList lits) - | None -> EList fles) - (* Base sets *) - | ESet les -> ESet (Expr.Set.elements (Expr.Set.of_list (List.map f les))) - | UnOp (NumToInt, UnOp (IntToNum, le)) -> f le - | UnOp (IntToNum, UnOp (NumToInt, le)) when PFS.mem pfs (UnOp (IsInt, le)) - -> f le - (* Number-to-string-to-number-to-string-to... *) - | UnOp (ToNumberOp, UnOp (ToStringOp, le)) -> ( - let fle = f le in - match fle with - | Lit (Num _) -> fle - | fle -> ( - let tfle, how = Typing.type_lexpr gamma fle in - match (how, tfle) with - | true, Some NumberType -> fle - | _, _ -> UnOp (ToNumberOp, UnOp (ToStringOp, fle)))) - | UnOp (LstRev, UnOp (LstRev, le)) -> f le - (* Less than and lessthaneq *) - | UnOp (Not, BinOp (le1, FLessThan, le2)) -> - f (BinOp (f le2, FLessThanEqual, f le1)) - | UnOp (Not, BinOp (le1, FLessThanEqual, le2)) -> - f (BinOp (f le2, FLessThan, f le1)) - (* Special equality *) - | BinOp - (BinOp (LVar x, FPlus, UnOp (FUnaryMinus, LVar y)), Equal, Lit (Num 0.)) - -> BinOp (LVar x, Equal, LVar y) - | BinOp - (BinOp (LVar x, IPlus, UnOp (IUnaryMinus, LVar y)), Equal, Lit (Int z)) - when Z.equal z Z.zero -> BinOp (LVar x, Equal, LVar y) - (* List indexing *) - | BinOp (le, LstNth, idx) -> ( - let fle = f le in - let fidx = f idx in - match fidx with - (* Index is a non-negative integer *) - | Lit (Int n) when Z.leq Z.zero n -> - if lexpr_is_list gamma fle then - Option.value - ~default:(Expr.BinOp (fle, LstNth, fidx)) - (get_nth_of_list pfs fle (Z.to_int n)) - else - let err_msg = - Fmt.str "LstNth(%a, %a): list is not a GIL list." Expr.pp fle - Expr.pp idx - in - L.normal (fun fmt -> fmt "%s" err_msg); - raise (ReductionException (BinOp (fle, LstNth, fidx), err_msg)) - (* Index is a number, but is either not an integer or is negative *) - | Lit (Int _) | Lit (Num _) -> - let err_msg = - "LstNth(list, index): index is smaller than zero or a float." - in - raise (ReductionException (BinOp (fle, LstNth, fidx), err_msg)) - (* All other cases *) - | _ -> BinOp (fle, LstNth, fidx)) - (* String indexing *) - | BinOp (le, StrNth, idx) -> ( - let fle = f le in - let fidx = f idx in - match fidx with - (* Index is a non-negative integer *) - | Lit (Num n) when Arith_utils.is_int n && 0. <= n -> ( - match lexpr_is_string gamma fle with - | true -> - Option.value - ~default:(Expr.BinOp (fle, StrNth, fidx)) - (get_nth_of_string fle (int_of_float n)) - | false -> - let err_msg = - "StrNth(str, index): string is not a GIL string." - in - raise - (ReductionException (Expr.BinOp (fle, StrNth, fidx), err_msg)) - ) - (* Index is a number, but is either not an integer or is negative *) - | Lit (Num _) -> - let err_msg = - "StrNth(str, index): index is non-integer or smaller than zero." + List.iter + (fun (x, t) -> + let () = + match Type_env.get new_gamma x with + | Some t -> + let new_var = List.assoc x subst_bindings in + Type_env.update new_gamma new_var t + | None -> () in - raise (ReductionException (Expr.BinOp (fle, StrNth, fidx), err_msg)) - (* All other cases *) - | _ -> BinOp (fle, StrNth, fidx)) - | NOp (SetUnion, les) -> ( - let fles = List.map f les in - (* Flatten unions *) - let unions, rest = - List.partition - (fun x -> - match x with - | Expr.NOp (SetUnion, _) -> true - | _ -> false) - fles - in - let unions = - List.fold_left - (fun ac u -> - let ls = - match u with - | Expr.NOp (SetUnion, ls) -> ls - | _ -> - raise (Failure "LSetUnion: flattening unions: impossible.") - in - ac @ ls) - [] unions - in - let fles = unions @ rest in - (* Join ESets *) - let lesets, rest = - List.partition - (fun x -> - match x with - | Expr.ESet _ -> true - | _ -> false) - fles - in - let lesets = - List.fold_left - (fun ac u -> - let ls = - match u with - | Expr.ESet ls -> ls - | _ -> raise (Failure "LSetUnion: joining ESets: impossible.") - in - ac @ ls) - [] lesets - in - let lesets = Expr.Set.elements (Expr.Set.of_list lesets) in - let fles = Expr.ESet lesets :: rest in - (* Remove empty sets *) - let fles = - List.filter - (function - | Expr.ESet [] -> false - | _ -> true) - fles - in - (* Remove duplicates *) - let fles = Expr.Set.elements (Expr.Set.of_list fles) in - match fles with - | [] -> ESet [] - | [ x ] -> x - | _ -> NOp (SetUnion, fles)) - | BinOp (x, LstRepeat, Lit (Int i)) when Z.lt i (Z.of_int 100) -> - let fx = f x in - let result = List.init (Z.to_int i) (fun _ -> fx) in - EList result - | NOp (LstCat, LstSub (x1, Lit (Int z), z1) :: LstSub (x2, y2, z3) :: rest) - when Z.equal z Z.zero && Expr.equal x1 x2 && Expr.equal z1 y2 -> - f - (NOp (LstCat, LstSub (x1, Expr.zero_i, BinOp (z1, IPlus, z3)) :: rest)) - | NOp (LstCat, fst :: rest) when PFS.mem pfs (BinOp (fst, Equal, EList [])) - -> f (NOp (LstCat, rest)) - | NOp (LstCat, [ x; LstSub (LVar y, UnOp (LstLen, x'), len) ]) - when x = x' - && Cint.canonicalise len - = Cint.canonicalise - (BinOp (UnOp (LstLen, LVar y), IMinus, UnOp (LstLen, x))) - && prefix_catch pfs x y -> LVar y - | NOp (LstCat, les) -> normalise_cat f les - | NOp (SetInter, [ BinOp (le1, SetDiff, le2); ESet le3 ]) -> - f (NOp (SetInter, [ le2; BinOp (ESet le3, SetDiff, le1) ])) - | NOp (SetInter, les) -> ( - let fles = List.map f les in - (* Flatten intersections *) - let inters, rest = - List.partition - (fun x -> - match x with - | Expr.NOp (SetInter, _) -> true - | _ -> false) - fles - in - let inters = - List.fold_left - (fun ac u -> - let ls = - match u with - | Expr.NOp (SetInter, ls) -> ls - | _ -> - raise - (Failure - "LSetInter: flattening intersections: impossible.") - in - ac @ ls) - [] inters - in - let fles = inters @ rest in - (* Join ESets *) - let lesets, rest = - List.partition - (fun x -> - match x with - | Expr.ESet _ -> true - | _ -> false) - fles - in - let lesets = - List.fold_left - (fun ac u -> - let ls = - match u with - | Expr.ESet ls -> ls - | _ -> raise (Failure "LSetUnion: joining ESets: impossible.") - in - ac @ ls) - [] lesets + match t with + | Some t -> Type_env.update new_gamma x t + | None -> Type_env.remove new_gamma x) + bt; + PFS.substitution subst new_pfs; + (* We reduce using our new pfs and gamma *) + let re = + reduce_lexpr_loop ~matching ~reduce_lvars new_pfs new_gamma e in - let lesets = Expr.Set.elements (Expr.Set.of_list lesets) in - let fles = Expr.ESet lesets :: rest in - (* If there is an empty set, the intersection is empty *) - if List.mem (Expr.ESet []) fles then Expr.ESet [] - else - let fles = Expr.Set.elements (Expr.Set.of_list fles) in - match fles with - | [] -> ESet [] - | [ x ] -> x - | _ -> NOp (SetInter, fles)) - | UnOp (FUnaryMinus, UnOp (FUnaryMinus, e)) -> f e - | UnOp (LstLen, BinOp (_, LstRepeat, e)) -> f e - | UnOp (LstLen, LstSub (_, _, e)) -> f e - | UnOp (op, le) -> ( - let fle = f le in - let def = Expr.UnOp (op, fle) in - match fle with - | Lit lit -> ( - try Lit (CExprEval.evaluate_unop op lit) with - | CExprEval.TypeError err_msg -> - raise (ReductionException (def, err_msg)) - | CExprEval.EvaluationError err_msg -> - raise (ReductionException (def, err_msg)) - | e -> raise e) - | _ -> ( - match op with - | Not -> ( - match fle with - | UnOp (Not, ex) -> f ex - | BinOp (ex, And, ey) -> - f (BinOp (UnOp (Not, ex), Or, UnOp (Not, ey))) - | BinOp (ex, Or, ey) -> - f (BinOp (UnOp (Not, ex), And, UnOp (Not, ey))) - | _ -> def) - (* The TypeOf operator *) - | TypeOf -> ( - let tfle, how = Typing.type_lexpr gamma fle in - match how with - | false -> - let err_msg = "LTypeOf(le): expression is not typable." in - raise (ReductionException (def, err_msg)) - | true -> ( - match tfle with - | None -> def - | Some t -> Lit (Type t))) - (* List head *) - | Car -> ( - match lexpr_is_list gamma fle with - | true -> - let ohdtl = get_head_and_tail_of_list ~pfs fle in - Option.fold ~some:(fun (hd, _) -> f hd) ~none:def ohdtl - | false -> - let err_msg = "UnOp(Car, list): list is not a GIL list." in - raise (ReductionException (def, err_msg))) - (* List tail *) - | Cdr -> ( - match lexpr_is_list gamma fle with - | true -> - let ohdtl = get_head_and_tail_of_list ~pfs fle in - Option.fold ~some:(fun (_, tl) -> f tl) ~none:def ohdtl - | false -> - let err_msg = "UnOp(Cdr, list): list is not a GIL list." in - raise (ReductionException (def, err_msg))) - (* List length *) - | LstLen -> ( - match lexpr_is_list gamma fle with - | true -> ( - match fle with - | Lit (LList le) -> Expr.int (List.length le) - | EList le -> Expr.int (List.length le) - | NOp (LstCat, les) -> - let les = List.map Expr.list_length les in - let le = - List.fold_left Expr.Infix.( + ) (List.hd les) - (List.tl les) - in - f le - | LstSub (_, _, len) -> len - | _ -> def) - | false -> - let err_msg = - "UnOp(LstLen, list): list is not a GIL list." - in - raise (ReductionException (def, err_msg))) - (* List reverse *) - | LstRev -> ( - match lexpr_is_list gamma fle with - | true -> ( - match fle with - | Lit (LList le) -> Lit (LList (List.rev le)) - | EList le -> EList (List.rev le) - | NOp (LstCat, les) -> - NOp - ( LstCat, - List.rev - (List.map (fun x -> Expr.UnOp (LstRev, x)) les) ) - | _ -> def) - | false -> - let err_msg = - "UnOp(LstRev, list): list is not a GIL list." - in - raise (ReductionException (def, err_msg))) - (* List reverse *) - | SetToList -> ( - match fle with - | ESet le -> EList (Expr.Set.elements (Expr.Set.of_list le)) - | _ -> def) - (* String length *) - | StrLen -> ( - match lexpr_is_string gamma fle with - | true -> - let len = get_length_of_string fle in - Option.fold - ~some:(fun len -> Expr.Lit (Num (float_of_int len))) - ~none:def len - | false -> - let err_msg = - "UnOp(StrLen, list): string is not a GIL string." - in - raise (ReductionException (def, err_msg))) - | FUnaryMinus when lexpr_is_number ~gamma def -> - simplify_num_arithmetic_lexpr pfs gamma def - | IUnaryMinus when lexpr_is_int ~gamma def -> - simplify_int_arithmetic_lexpr pfs gamma def - | _ -> UnOp (op, fle))) - (* Nested L-sub *) - | LstSub (LstSub (ile1, ile2, ile3), fle2, fle3) + let vars = Expr.lvars re in + let bt = List.filter (fun (b, _) -> Containers.SS.mem b vars) bt in + (* We remove all quantifiers that aren't used anymore *) + match (le, bt) with + | _, [] -> re + | ForAll _, _ -> ForAll (bt, re) + | Exists _, _ -> Exists (bt, re) + | _, _ -> failwith "Impossible.") + (* ------------------------- + LstSub + ------------------------- *) + | LstSub (LstSub (ile1, ile2, _), _, _) when match find_lstsub_inn ile1 ile2 with - | LVar x, _ + | (LVar _ as x), _ when List.exists - (fun x -> - match x with + (function | Expr.LVar _ -> false | _ -> true) - (find_equalities pfs (LVar x)) -> true - | _, LVar x + (find_equalities pfs x) -> true + | _, (LVar _ as x) when List.exists - (fun x -> - match x with + (function | Expr.LVar _ -> false | _ -> true) - (find_equalities pfs (LVar x)) -> true - | _ -> false -> ( - let fle1 = Expr.LstSub (ile1, ile2, ile3) in - let base_expr = Expr.LstSub (fle1, fle2, fle3) in - + (find_equalities pfs x) -> true + | _ -> false -> + (* We (painfully) found out that we can substitute something + from an LVar to a non-LVar -- now we do it, avoiding getting + results more than once. *) let inn_lst, inn_start = find_lstsub_inn ile1 ile2 in - match (inn_lst, inn_start) with - | LVar x, _ - when List.exists - (fun x -> - match x with - | Expr.LVar _ -> false - | _ -> true) - (find_equalities pfs (LVar x)) -> - (* L.verbose (fun fmt -> - fmt "Reducing: %a\n1st: Innermost list and start: %a and %a" - Expr.pp base_expr Expr.pp inn_lst Expr.pp inn_start); *) - let eqs = - List.filter - (fun x -> - match x with - | Expr.LVar _ -> false - | _ -> true) - (find_equalities pfs (LVar x)) - in - let subst_expr = List.hd eqs in - let att_exp = - Expr.subst_expr_for_expr ~to_subst:(LVar x) ~subst_with:subst_expr - base_expr - in - let reduced_att_exp = f att_exp in - (* L.verbose (fun fmt -> - fmt "1st: Attempted and reduced expr: %a and %a" Expr.pp att_exp - Expr.pp reduced_att_exp); *) - if att_exp = reduced_att_exp then LstSub (fle1, fle2, fle3) - else reduced_att_exp - | _, LVar x - when List.exists - (fun x -> - match x with - | Expr.LVar _ -> false - | _ -> true) - (find_equalities pfs (LVar x)) -> - (* L.verbose (fun fmt -> - fmt "Reducing: %a\n2nd: Innermost list and start: %a and %a" - Expr.pp base_expr Expr.pp inn_lst Expr.pp inn_start); *) - let eqs = - List.filter - (fun x -> - match x with - | Expr.LVar _ -> false - | _ -> true) - (find_equalities pfs (LVar x)) - in - let subst_expr = List.hd eqs in - let att_exp = - Expr.subst_expr_for_expr ~to_subst:(LVar x) ~subst_with:subst_expr - base_expr - in - let reduced_att_exp = f att_exp in - (* L.verbose (fun fmt -> - fmt "2nd: Attempted and reduced expr: %a and %a" Expr.pp att_exp - Expr.pp reduced_att_exp); *) - if att_exp = reduced_att_exp then LstSub (fle1, fle2, fle3) - else reduced_att_exp - | _, _ -> LstSub (fle1, fle2, fle3)) + let to_subst, subst_with = + let list_eqs = + match inn_lst with + | LVar _ -> + find_equalities pfs inn_lst + |> List.filter (function + | Expr.LVar _ -> false + | _ -> true) + | _ -> [] + in + match list_eqs with + | x :: _ -> (inn_lst, x) + | [] -> + let x = + find_equalities pfs inn_start + |> List.find (function + | Expr.LVar _ -> false + | _ -> true) + in + (inn_start, x) + in + let att_exp = Expr.subst_expr_for_expr ~to_subst ~subst_with le in + let reduced_att_exp = f att_exp in + (* We can't reduce further, so useless - throw away *) + if att_exp = reduced_att_exp then le else reduced_att_exp + (* If: + - l[n..(len(l))] with n a constant + - l is of the form l1 ++ l2 ++ ... ++ lm + - len(l1) = n and !(m = 2 && l2 = l) (ie. a recursive list??) + Then we reduce to l2 ++ ... ++ lm *) | LstSub (l, Lit (Int n), BinOp (UnOp (LstLen, l'), IMinus, Lit (Int n'))) when l = l' && n == n' && @@ -1427,20 +1075,16 @@ and reduce_lexpr_loop | _ -> false) eqs -> Logging.tmi (fun m -> m "REDUCTION: Case l-sub(l, n, (l-len l) - n)"); - let eqs = get_equal_expressions pfs l in - let cat = - List.filter_map - (function - | Expr.NOp (LstCat, EList les :: rest) - when Int.equal (List.compare_length_with les (Z.to_int n)) 0 -> - Some (Expr.NOp (LstCat, rest)) - | NOp (LstCat, Lit (LList les) :: rest) - when Int.equal (List.compare_length_with les (Z.to_int n)) 0 -> - Some (NOp (LstCat, rest)) - | _ -> None) - eqs - in - f (List.hd cat) + get_equal_expressions pfs l + |> List.find_map (function + | Expr.NOp (LstCat, EList les :: rest) + when Int.equal (List.compare_length_with les (Z.to_int n)) 0 -> + Some (Expr.NOp (LstCat, rest)) + | NOp (LstCat, Lit (LList les) :: rest) + when Int.equal (List.compare_length_with les (Z.to_int n)) 0 -> + Some (NOp (LstCat, rest)) + | _ -> None) + |> Option.get |> f | LstSub (e1, Lit (Int z), e3) when Z.equal z Z.zero && List.mem (Cint.of_expr e3) (find_list_length_eqs pfs e1) -> f e1 @@ -1715,355 +1359,939 @@ and reduce_lexpr_loop | _ -> L.tmi (fun fmt -> fmt "Case 15"); LstSub (fle1, fle2, fle3)) - (* CHECK: FTimes and Div are the same, how does the 'when' scope? *) - | BinOp (lel, op, ler) -> ( - let flel, fler = - (* If we're reducing A || B or A && B and either side have a reduction exception, it must be false *) - let flel = - try f lel with - | ReductionException _ when op = Or || op = And -> Expr.bool false - | exn -> raise exn - in - let fler = - try f ler with - | ReductionException _ when op = Or || op = And -> Expr.bool false - | exn -> raise exn - in - (flel, fler) - in - let def = Expr.BinOp (flel, op, fler) in - match (flel, fler) with - | Lit ll, Lit lr -> ( - try - Lit - (CExprEval.evaluate_binop (CStore.init []) op (Lit ll) (Lit lr)) - with + (* ------------------------- + UnOp + ------------------------- *) + | UnOp (NumToInt, UnOp (IntToNum, le)) -> f le + | UnOp (IntToNum, UnOp (NumToInt, le)) when PFS.mem pfs (UnOp (IsInt, le)) + -> f le + (* Number-to-string-to-number-to-string-to... *) + | UnOp (ToNumberOp, UnOp (ToStringOp, le)) -> ( + let fle = f le in + match fle with + | Lit (Num _) -> fle + | _ -> ( + let tfle, how = Typing.type_lexpr gamma fle in + match (how, tfle) with + | true, Some NumberType -> fle + | _, _ -> UnOp (ToNumberOp, UnOp (ToStringOp, fle)))) + | UnOp (LstRev, UnOp (LstRev, le)) -> f le + (* Less than and lessthaneq *) + | UnOp (Not, BinOp (le1, FLessThan, le2)) -> + f (BinOp (f le2, FLessThanEqual, f le1)) + | UnOp (Not, BinOp (le1, FLessThanEqual, le2)) -> + f (BinOp (f le2, FLessThan, f le1)) + | UnOp (Not, BinOp (le1, ILessThan, le2)) -> + f (BinOp (f le2, ILessThanEqual, f le1)) + | UnOp (Not, BinOp (le1, ILessThanEqual, le2)) -> + f (BinOp (f le2, ILessThan, f le1)) + | UnOp (FUnaryMinus, UnOp (FUnaryMinus, e)) -> f e + | UnOp (IUnaryMinus, UnOp (IUnaryMinus, e)) -> f e + | UnOp (LstLen, BinOp (_, LstRepeat, e)) -> f e + | UnOp (LstLen, LstSub (_, _, e)) -> f e + | UnOp (op, le) -> ( + let fle = f le in + let def = Expr.UnOp (op, fle) in + match (op, fle) with + | _, Lit lit -> ( + try Lit (CExprEval.evaluate_unop op lit) with | CExprEval.TypeError err_msg -> raise (ReductionException (def, err_msg)) | CExprEval.EvaluationError err_msg -> raise (ReductionException (def, err_msg)) | e -> raise e) - | _ -> ( - match - reduce_binop_inttonum_const matching reduce_lvars pfs gamma flel - fler op - with - | Some e -> e - | None -> ( - match op with - | Equal -> ( - if Expr.equal flel fler then Lit (Bool true) - else if - PFS.exists - (fun e -> - Expr.equal e (BinOp (flel, Equal, fler)) - || Expr.equal e (BinOp (fler, Equal, flel))) - pfs - then Lit (Bool true) - else if - PFS.mem pfs (UnOp (Not, BinOp (flel, Equal, fler))) - || PFS.mem pfs (UnOp (Not, BinOp (fler, Equal, flel))) - then Lit (Bool false) - else - let t1, _ = Typing.type_lexpr gamma flel in - let t2, _ = Typing.type_lexpr gamma fler in - match (t1, t2) with - | Some t1, Some t2 -> - if Type.equal t1 t2 then def else Lit (Bool false) - | _, _ -> ( - match (flel, fler) with - | UnOp (NumToInt, flel'), _ -> - BinOp (flel', op, UnOp (IntToNum, fler)) - | _, UnOp (NumToInt, fler') -> - BinOp (UnOp (IntToNum, flel), op, fler') - | _, _ -> def)) - | (FPlus | FMinus) when lexpr_is_number ~gamma def -> - simplify_num_arithmetic_lexpr pfs gamma def - | (IPlus | IMinus) when lexpr_is_int ~gamma def -> - simplify_int_arithmetic_lexpr pfs gamma def - | FTimes when lexpr_is_number ~gamma def -> ( - match (flel, fler) with - (* 1 is the neutral *) - | Lit (Num 1.), x | x, Lit (Num 1.) -> x - | Lit (Num x), _ when x == nan -> Lit (Num nan) - | _, Lit (Num x) when x == nan -> Lit (Num nan) - | BinOp (Lit (Num x), FTimes, y), Lit (Num z) - | Lit (Num z), BinOp (Lit (Num x), FTimes, y) -> - BinOp (Lit (Num (z *. x)), FTimes, y) - (* Rest *) - | _, _ -> def) - | ITimes when lexpr_is_int ~gamma def -> ( - match (flel, fler) with - | Lit (Int z), x when Z.equal z Z.one -> x - | x, Lit (Int z) when Z.equal z Z.one -> x - | (Lit (Int z) as zero), _ when Z.equal z Z.zero -> zero - | _, (Lit (Int z) as zero) when Z.equal z Z.zero -> zero - | BinOp (Lit (Int x), ITimes, y), Lit (Int z) - | Lit (Int z), BinOp (Lit (Int x), ITimes, y) -> - BinOp (Lit (Int (Z.mul z x)), ITimes, y) - | _, _ -> def) - | FDiv when lexpr_is_number ~gamma def -> ( - match (flel, fler) with - (* 1 is the neutral *) - | x, Lit (Num 1.) -> x - | _, _ -> def) - | IDiv when lexpr_is_int ~gamma def -> ( - match (flel, fler) with - | x, Lit (Int o) when Z.equal o Z.one -> x - | _, _ -> def) - | And when lexpr_is_bool gamma def -> ( - match (flel, fler) with - (* 1 is the neutral *) - | Lit (Bool true), x | x, Lit (Bool true) -> x - | Lit (Bool false), _ | _, Lit (Bool false) -> - Lit (Bool false) - (* Rest *) - | _, _ -> - let fal, nfal = - Option.get @@ Expr.as_boolean_expr flel - in - let far, nfar = - Option.get @@ Expr.as_boolean_expr fler - in - if PFS.mem pfs nfal || PFS.mem pfs nfar then - Lit (Bool false) - else if PFS.mem pfs fal then f fler - else if PFS.mem pfs far then f flel - else BinOp (flel, And, fler)) - | Or when lexpr_is_bool gamma def -> ( - match (flel, fler) with - (* 1 is the neutral *) - | Lit (Bool true), _ | _, Lit (Bool true) -> Lit (Bool true) - | Lit (Bool false), x | x, Lit (Bool false) -> x - (* Rest *) - | _, _ -> - let fal, nfal = - Option.get @@ Expr.as_boolean_expr flel - in - let far, nfar = - Option.get @@ Expr.as_boolean_expr fler - in - if PFS.mem pfs fal || PFS.mem pfs far then - Lit (Bool true) - else if PFS.mem pfs nfal then f fler - else if PFS.mem pfs nfar then f flel - else BinOp (flel, Or, fler)) - | StrCat when lexpr_is_string gamma def -> ( - match (flel, fler) with - (* Empty list is the neutral *) - | x, Lit (String "") | Lit (String ""), x -> x - (* Rest *) - | BinOp (el, StrCat, Lit (String s1)), Lit (String s2) -> - f (BinOp (el, StrCat, Lit (String (s1 ^ s2)))) - | _, _ -> def) - | SetDiff when lexpr_is_set gamma def -> ( - let pfs = PFS.to_list pfs in - if contained_in_union pfs flel fler then ESet [] - else - match (flel, fler) with - | x, y when x = y -> ESet [] - | ESet [], _ -> ESet [] - | x, ESet [] -> x - | ESet left, ESet right - when Expr.all_literals left && Expr.all_literals right - -> - ESet - (Expr.Set.elements - (Expr.Set.diff (Expr.Set.of_list left) - (Expr.Set.of_list right))) - | ESet left, s when Expr.all_literals left -> - if List.for_all (fun x -> set_member pfs x s) left - then ESet [] - else def - | ESet left, ESet right -> - L.verbose (fun fmt -> - fmt "Inside relevant SetDiff case."); - let candidate_result = - Expr.Set.elements - (Expr.Set.diff (Expr.Set.of_list left) - (Expr.Set.of_list right)) - in - L.verbose (fun fmt -> - fmt "Candidate result: %a" - Fmt.(brackets (list ~sep:comma Expr.pp)) - candidate_result); - let result = - if - List.for_all - (fun x -> not_set_member pfs x (ESet right)) - candidate_result - then Expr.ESet candidate_result - else def - in - L.verbose (fun fmt -> - fmt "Actual result: %a" Expr.pp result); - result - | NOp (SetUnion, les), _ -> - let diffs = - List.map - (fun le -> f (BinOp (le, SetDiff, fler))) - les - in - NOp (SetUnion, diffs) - | _, NOp (SetUnion, les) -> - f - (NOp - ( SetInter, - List.map - (fun le -> Expr.BinOp (flel, SetDiff, le)) - les )) - | x, ESet [ el ] - when List.mem - (Expr.UnOp (Not, BinOp (el, SetMem, x))) - pfs -> x - | LVar _, _ -> - if set_subset pfs flel fler then ESet [] else def - | ESet les, fler -> ( - (* We must know that the elements of les are all different, and for that we need the pure formulae *) - match all_different pfs les with - | false -> def - | true -> - let _, rest = - List.partition - (fun x -> set_member pfs x fler) - les - in - if - List.for_all - (fun x -> not_set_member pfs x fler) - rest - then ESet rest - else BinOp (ESet rest, SetDiff, fler)) - | _, _ -> def) - (* let hM = f (BinOp (flel, SetSub, fler)) in - (match hM with - | Lit (Bool true) -> ESet [] - | _ -> def)) *) - | SetMem when lexpr_is_bool gamma def -> ( - match (flel, fler) with - | _, ESet [] -> Lit (Bool false) - | _, ESet [ x ] -> BinOp (flel, Equal, x) - | le, ESet les -> ( - match List.mem le les with - | true -> Lit (Bool true) - | false -> ( - match le with - | Lit _ -> - if Expr.all_literals les then Lit (Bool false) - else def - | _ -> def)) - | _, _ -> def) - | SetSub when lexpr_is_bool gamma def -> ( - match (flel, fler) with - | ESet [], _ -> Lit (Bool true) - | _, ESet [] -> Lit (Bool false) - | ESet left, ESet right - when Expr.all_literals left && Expr.all_literals right -> - Lit - (Bool - (Expr.Set.subset (Expr.Set.of_list left) - (Expr.Set.of_list right))) - | LVar _, NOp (SetUnion, les) -> - if List.mem flel les then Lit (Bool true) else def - | _, _ -> def) - | FLessThan -> - let success, el, er = Cnum.cut flel fler in - let nexpr = Expr.BinOp (el, FLessThan, er) in - if success then f nexpr else nexpr - | ILessThan -> ( - match (flel, fler) with - | x, fler - when let fler_len = substitute_for_list_length pfs fler in - match fler_len with - | UnOp (LstLen, _) -> true - | _ -> false -> - f - (BinOp - ( BinOp (x, IPlus, Lit (Int Z.one)), - ILessThanEqual, - fler )) - | UnOp (LstLen, _), Lit (Int n) when Z.leq n Z.zero -> - Lit (Bool false) - | UnOp (LstLen, le), Lit (Int z) when Z.equal z Z.one -> - BinOp (le, Equal, EList []) - | _ -> - let success, el, er = Cint.cut flel fler in - let nexpr = Expr.BinOp (el, ILessThan, er) in - if success then f nexpr else nexpr - (* | _, _ -> - f - (BinOp - (BinOp (flel, FMinus, fler), FLessThan, Lit (Num 0.))) *) - ) - | FLessThanEqual -> ( - let success, el, er = Cnum.cut flel fler in - if success then f (BinOp (el, FLessThanEqual, er)) - else - match - check_ge_zero_num ~top_level:true pfs - (f (BinOp (fler, FMinus, flel))) - with - | Some x -> Lit (Bool x) - | None -> def) - | ILessThanEqual -> ( - let success, el, er = Cint.cut flel fler in - if success then f (BinOp (el, ILessThanEqual, er)) - else - match - check_ge_zero_int ~top_level:true pfs - (f (BinOp (fler, IMinus, flel))) - with - | Some x -> Lit (Bool x) - | None -> def) - | _ -> def))) - | ForAll (bt, e) | Exists (bt, e) -> ( - (* We create a new pfs and gamma where: - - All shadowed variables are substituted with a fresh variable - - The gamma has been updated with the types given in the binder *) - let new_gamma = Type_env.copy gamma in - let new_pfs = PFS.copy pfs in - let subst_bindings = List.map (fun (x, _) -> (x, LVar.alloc ())) bt in - let subst = - SVal.SESubst.init - (List.map (fun (x, y) -> (Expr.LVar x, Expr.LVar y)) subst_bindings) + (* Negation *) + | Not, UnOp (Not, ex) -> f ex + | Not, BinOp (ex, And, ey) -> + f (BinOp (UnOp (Not, ex), Or, UnOp (Not, ey))) + | Not, BinOp (ex, Or, ey) -> + f (BinOp (UnOp (Not, ex), And, UnOp (Not, ey))) + | Not, _ -> def + (* The TypeOf operator *) + | TypeOf, _ -> ( + let tfle, how = Typing.type_lexpr gamma fle in + match how with + | false -> + let err_msg = "LTypeOf(le): expression is not typable." in + raise (ReductionException (def, err_msg)) + | true -> ( + match tfle with + | None -> def + | Some t -> Lit (Type t))) + (* List operations: head, tail *) + | Car, EList (hd :: _) -> hd + | Car, _ when lexpr_is_list gamma fle -> + let ohdtl = get_head_and_tail_of_list ~pfs fle in + Option.fold ~some:(fun (hd, _) -> f hd) ~none:def ohdtl + | Cdr, EList (_ :: tl) -> EList tl + | Cdr, _ when lexpr_is_list gamma fle -> + let ohdtl = get_head_and_tail_of_list ~pfs fle in + Option.fold ~some:(fun (_, tl) -> f tl) ~none:def ohdtl + (* List operations: length *) + | LstLen, EList le -> Expr.int (List.length le) + | LstLen, NOp (LstCat, les) when lexpr_is_list gamma fle -> + let les = List.map Expr.list_length les in + let le = + List.fold_left Expr.Infix.( + ) (List.hd les) (List.tl les) + in + f le + | LstLen, LstSub (_, _, len) when lexpr_is_list gamma fle -> len + | LstLen, _ when lexpr_is_list gamma fle -> def + (* List operations: reverse *) + | LstRev, EList le -> EList (List.rev le) + | LstRev, NOp (LstCat, les) when lexpr_is_list gamma fle -> + NOp (LstCat, List.rev_map (fun x -> Expr.UnOp (LstRev, x)) les) + | LstRev, _ when lexpr_is_list gamma fle -> def + (* List operations when not lists *) + | Car, _ | Cdr, _ | LstLen, _ | LstRev, _ -> + let err_msg = + Fmt.str "UnOp(%s, list): list is not a GIL list." (UnOp.str op) + in + raise (ReductionException (def, err_msg)) + (* Set operation *) + | SetToList, ESet le -> EList (Expr.Set.elements (Expr.Set.of_list le)) + (* String length *) + | StrLen, _ when lexpr_is_string gamma fle -> + let len = get_length_of_string fle in + Option.fold + ~some:(fun len -> Expr.Lit (Num (float_of_int len))) + ~none:def len + | StrLen, _ -> + let err_msg = "UnOp(StrLen, list): string is not a GIL string." in + raise (ReductionException (def, err_msg)) + (* Minus *) + | FUnaryMinus, _ when lexpr_is_number ~gamma def -> + simplify_num_arithmetic_lexpr pfs gamma def + | IUnaryMinus, _ when lexpr_is_int ~gamma def -> + simplify_int_arithmetic_lexpr pfs gamma def + (* IsInt *) + | IsInt, UnOp (IntToNum, e) -> ( + match Typing.type_lexpr gamma e with + | Some IntType, _ -> Expr.true_ + | Some _, _ -> Expr.false_ + | None, _ -> f (BinOp (UnOp (TypeOf, e), Equal, Lit (Type IntType))) + ) + | _, _ -> def) + (* ------------------------- + NOp + ------------------------- *) + (* List concatenation *) + (* l[0..n] ++ l[n..n+m] ++ rest <=> l[0..n+m] ++ rest *) + | NOp (LstCat, LstSub (x1, Lit (Int z), z1) :: LstSub (x2, y2, z3) :: rest) + when Z.equal z Z.zero && Expr.equal x1 x2 && Expr.equal z1 y2 -> + f + (NOp (LstCat, LstSub (x1, Expr.zero_i, Expr.Infix.( + ) z1 z3) :: rest)) + | NOp (LstCat, fst :: rest) when PFS.mem pfs (BinOp (fst, Equal, EList [])) + -> f (NOp (LstCat, rest)) + | NOp (LstCat, [ x; LstSub (LVar y, UnOp (LstLen, x'), len) ]) + when x = x' + && Cint.canonicalise len + = Cint.canonicalise + (BinOp (UnOp (LstLen, LVar y), IMinus, UnOp (LstLen, x))) + && prefix_catch pfs x y -> LVar y + | NOp (LstCat, les) -> normalise_cat f les + (* Set union *) + | NOp (SetUnion, les) -> ( + let fles = List.map f les in + (* Flatten unions *) + let fles = + List.concat_map + (function + | Expr.NOp (SetUnion, les) -> les + | le -> [ le ]) + fles + in + (* Join ESets *) + let lesets, rest = + List.partition_map + (function + | Expr.ESet es -> Left es + | e -> Right e) + fles + in + let lesets = List.concat lesets in + (* Merge together, without duplicates *) + let rest = rest |> Expr.Set.of_list |> Expr.Set.elements in + let fles = + match lesets with + | [] -> rest + | _ -> + (* TODO: Check is List.sort_uniq is faster than Set *) + let lesets = lesets |> Expr.Set.of_list |> Expr.Set.elements in + Expr.ESet lesets :: rest in - let () = - List.iter - (fun (x, t) -> - let () = - match Type_env.get new_gamma x with - | Some t -> - let new_var = List.assoc x subst_bindings in - Type_env.update new_gamma new_var t - | None -> () + (* Remove duplicates *) + match fles with + | [] -> ESet [] + | [ x ] -> x + | _ -> NOp (SetUnion, fles)) + (* Set intersection *) + | NOp (SetInter, [ BinOp (le1, SetDiff, le2); ESet le3 ]) -> + f (NOp (SetInter, [ le2; BinOp (ESet le3, SetDiff, le1) ])) + | NOp (SetInter, les) -> ( + let fles = List.map f les in + (* Flatten intersections *) + let fles = + List.concat_map + (function + | Expr.NOp (SetInter, es) -> es + | e -> [ e ]) + fles + in + (* Join ESets *) + let lesets, rest = + List.partition_map + (function + | Expr.ESet es -> Left es + | e -> Right e) + fles + in + let lesets = List.concat lesets in + (* Merge together, without duplicates *) + match (lesets, rest) with + | [], _ -> ESet [] + | _, [] -> + let lesets = lesets |> Expr.Set.of_list |> Expr.Set.elements in + Expr.ESet lesets + | _ -> + let lesets = lesets |> Expr.Set.of_list |> Expr.Set.elements in + let rest = rest |> Expr.Set.of_list |> Expr.Set.elements in + let fles = Expr.ESet lesets :: rest in + NOp (SetInter, fles)) + (* ------------------------- + BinOp + (terrifying) + ------------------------- *) + (* BinOps: Equalities (basics) *) + | BinOp (e1, Equal, e2) when Expr.equal e1 e2 -> Expr.true_ + | BinOp (UnOp (op, e1), Equal, UnOp (op', e2)) when UnOp.equal op op' -> + BinOp (e1, Equal, e2) + (* BinOps: Equalities (locations) *) + (* This line is the central mechanism to "matching": *) + | BinOp (ALoc x, Equal, ALoc y) when not matching -> Lit (Bool (x = y)) + | BinOp (ALoc _, Equal, Lit (Loc _)) | BinOp (Lit (Loc _), Equal, ALoc _) -> + Expr.false_ + (* BinOps: Equalities (lists) *) + | BinOp (Lit (LList ll), Equal, Lit (LList lr)) -> Expr.bool (ll = lr) + | BinOp (EList le, Equal, Lit (LList ll)) + | BinOp (Lit (LList ll), Equal, EList le) -> + if List.length ll <> List.length le then Expr.false_ + else if ll = [] then Expr.true_ + else + List.map2 (fun x y -> Expr.Infix.( == ) x (Lit y)) le ll + |> Expr.conjunct |> f + | BinOp (EList ll, Equal, EList lr) -> + if List.length ll <> List.length lr then Expr.(false_) + else if ll = [] then Expr.(true_) + else List.map2 Expr.Infix.( == ) ll lr |> Expr.conjunct |> f + | BinOp (left_list, Equal, right_list) + when (*(match + ( Typing.type_lexpr gamma left_list, + Typing.type_lexpr gamma right_list ) + with + | (Some Type.ListType, _), (Some Type.ListType, _) -> true + | _ -> false)*) + lexpr_is_list gamma left_list + && lexpr_is_list gamma right_list + && + match + f + (Expr.Infix.( - ) + (Expr.list_length left_list) + (Expr.list_length right_list)) + with + | Expr.Lit (Int k) when not (Z.equal k Z.zero) -> true + | _ -> false -> + (* If we have two lists but can reduce the equality of their lengths to false, + then we know the lists cannot be equal*) + Expr.false_ + (* x = l1 ++ ... ++ ln when x = li and there is a non empty list => false *) + | BinOp (NOp (LstCat, les), Equal, (LVar _ as x)) + when List.mem x les + && List.exists + (function + | Expr.EList (_ :: _) | Lit (LList (_ :: _)) -> true + | _ -> false) + les -> Expr.false_ + (* l[0..n] = l <=> n = len(l) *) + | BinOp (LstSub (e1, Lit (Int z), el), Equal, e2) + when Z.equal z Z.zero && Expr.equal e1 e2 -> + BinOp (UnOp (LstLen, e1), Equal, el) + | BinOp (e2, Equal, LstSub (e1, Lit (Int z), el)) + when Z.equal z Z.zero && Expr.equal e1 e2 -> + BinOp (UnOp (LstLen, e1), Equal, el) + | BinOp (UnOp (LstRev, ll), Equal, UnOp (LstRev, rl)) -> + BinOp (ll, Equal, rl) + (* (l ++ ...)[0..n] = l <==> n = len(l) *) + | BinOp (e2, Equal, LstSub (NOp (LstCat, e1 :: _), Lit (Int z), el)) + when Z.equal z Z.zero && Expr.equal e1 e2 -> + BinOp (UnOp (LstLen, e1), Equal, el) + | BinOp (LstSub (NOp (LstCat, e1 :: _), Lit (Int z), el), Equal, e2) + when Z.equal z Z.zero && Expr.equal e1 e2 -> + BinOp (UnOp (LstLen, e1), Equal, el) + (* l = (l1 ++ l ++ ...)[n..m] <=> n = len(l1) /\ m = len(l) *) + | BinOp (e2, Equal, LstSub (NOp (LstCat, e3 :: e1 :: _), ex, ey)) + when Expr.equal e1 e2 -> + BinOp + ( BinOp (UnOp (LstLen, e3), Equal, ex), + And, + BinOp (UnOp (LstLen, e1), Equal, ey) ) + | BinOp (LstSub (NOp (LstCat, e3 :: e1 :: _), ex, ey), Equal, e2) + when Expr.equal e1 e2 -> + BinOp + ( BinOp (UnOp (LstLen, e3), Equal, ex), + And, + BinOp (UnOp (LstLen, e1), Equal, ey) ) + (* l ++ l1 = l ++ l2 <=> l1 = l2 *) + | BinOp (NOp (LstCat, fl :: rl), Equal, NOp (LstCat, fr :: rr)) + when Expr.equal fl fr -> BinOp (NOp (LstCat, rl), Equal, NOp (LstCat, rr)) + (* la ++ ... ++ l = lb ++ ... ++ l <=> la ++ ... = lb ++ ... *) + | BinOp + ( NOp (LstCat, (_ :: (_ :: _ as rl) as fl)), + Equal, + NOp (LstCat, (_ :: (_ :: _ as rr) as fr)) ) + when let last l = List.hd @@ List.rev l in + Expr.equal (last rl) (last rr) -> + let rem_last l = List.rev @@ List.tl @@ List.rev l in + BinOp (NOp (LstCat, rem_last fl), Equal, NOp (LstCat, rem_last fr)) + (* l = l[0..s] ++ ... /\ len(l) < s <=> false *) + | BinOp + ( LVar lst, + Equal, + NOp (LstCat, LstSub (LVar lst', Lit (Int z), split) :: _) ) + when Z.equal z Z.zero && String.equal lst lst' + && PFS.mem pfs (BinOp (UnOp (LstLen, LVar lst), ILessThan, split)) -> + Expr.false_ + (* l U {x} = l' U {x} /\ x ∉ l /\ x ∉ l' <=> l = l' *) + | BinOp + ( NOp (SetUnion, [ ls; ESet [ lx ] ]), + Equal, + NOp (SetUnion, [ rs; ESet [ rx ] ]) ) + when lx = rx + && PFS.mem pfs (UnOp (Not, BinOp (lx, SetMem, ls))) + && PFS.mem pfs (UnOp (Not, BinOp (lx, SetMem, rs))) -> + BinOp (ls, Equal, rs) + (* BinOps: Equalities (maths) *) + (* These always map to a boolean so no need for =. + Could be simplified with an fn that maps BinOp -> ret type *) + | BinOp + ( Lit (Bool true), + Equal, + (BinOp + ( _, + ( Equal + | ILessThan + | ILessThanEqual + | FLessThan + | FLessThanEqual + | StrLess + | And + | Or + | Impl + | SetMem + | SetSub ), + _ ) as e) ) -> e + | BinOp (Lit (Bool false), Equal, BinOp (e1, ILessThan, e2)) -> + BinOp (e2, ILessThanEqual, e1) + | BinOp (Lit (Bool false), Equal, BinOp (e1, ILessThanEqual, e2)) -> + BinOp (e2, ILessThan, e1) + | BinOp (Lit (Bool false), Equal, BinOp (e1, FLessThan, e2)) -> + BinOp (e2, FLessThanEqual, e1) + | BinOp (Lit (Bool false), Equal, BinOp (e1, FLessThanEqual, e2)) -> + BinOp (e2, FLessThan, e1) + | BinOp (* x + (-y) = 0f <=> x = y *) + (BinOp (LVar x, FPlus, UnOp (FUnaryMinus, LVar y)), Equal, Lit (Num 0.)) + -> BinOp (LVar x, Equal, LVar y) + | BinOp (* x + (-y) = 0i <=> x = y *) + (BinOp (LVar x, IPlus, UnOp (IUnaryMinus, LVar y)), Equal, Lit (Int z)) + when Z.equal z Z.zero -> BinOp (LVar x, Equal, LVar y) + | BinOp (BinOp (Lit (Num x), FPlus, LVar y), Equal, LVar z) + when x <> 0. && String.equal y z -> Expr.false_ + | BinOp (BinOp (Lit (Int x), IPlus, LVar y), Equal, LVar z) + when (not (Z.equal x Z.zero)) && String.equal y z -> Expr.false_ + (* FIXME: INTEGER BYTE-BY-BYTE BREAKDOWN *) + (* 256 * b1 + b0 = n /\ b0,b1 ∈ [0;256[ <==> b1 = n/256 /\ b0 = n-b1 + Opale: The b0 = n-b1 bit is weird?? Why not mod? *) + | BinOp + ( Lit (Int n), + Equal, + BinOp + ( BinOp (Lit (Int tfs), ITimes, (LVar _ as b1)), + IPlus, + (LVar _ as b0) ) ) + when (*top_level &&*) + Z.equal tfs _256 + && PFS.mem pfs (BinOp (Expr.zero_i, ILessThanEqual, b0)) + && PFS.mem pfs (BinOp (Expr.zero_i, ILessThanEqual, b1)) + && PFS.mem pfs (BinOp (b0, ILessThan, Lit (Int _256))) + && PFS.mem pfs (BinOp (b1, ILessThan, Lit (Int _256))) -> + if Z.gt n _65535 then Expr.false_ + else + let vb1 = Z.div n _256 in + let vb0 = Z.sub n vb1 in + BinOp + ( BinOp (b1, Equal, Lit (Int vb1)), + And, + BinOp (b0, Equal, Lit (Int vb0)) ) + | BinOp + ( BinOp + ( BinOp (Lit (Int tfs), ITimes, (LVar _ as b1)), + IPlus, + (LVar _ as b0) ), + Equal, + Lit (Int n) ) + when (*top_level &&*) + Z.equal tfs _256 + && PFS.mem pfs (BinOp (Expr.zero_i, ILessThanEqual, b0)) + && PFS.mem pfs (BinOp (Expr.zero_i, ILessThanEqual, b1)) + && PFS.mem pfs (BinOp (b0, ILessThan, Lit (Int _256))) + && PFS.mem pfs (BinOp (b1, ILessThan, Lit (Int _256))) -> + if Z.gt n _65535 then Expr.false_ + else + let vb1 = Z.div n _256 in + let vb0 = Z.sub n vb1 in + BinOp + ( BinOp (b1, Equal, Lit (Int vb1)), + And, + BinOp (b0, Equal, Lit (Int vb0)) ) + | BinOp (BinOp (e, FTimes, Lit (Num x)), Equal, Lit (Num 0.)) when x <> 0. + -> BinOp (e, Equal, Lit (Num 0.)) + | BinOp (BinOp (Lit (Num x), FTimes, e), Equal, Lit (Num 0.)) when x <> 0. + -> BinOp (e, Equal, Lit (Num 0.)) + | BinOp (BinOp (e, ITimes, Lit (Int x)), Equal, Lit (Int n)) + when Z.equal n Z.zero && not (Z.equal x Z.zero) -> + BinOp (e, Equal, Expr.zero_i) + | BinOp (BinOp (Lit (Int x), ITimes, e), Equal, Lit (Int n)) + when Z.equal n Z.zero && not (Z.equal x Z.zero) -> + BinOp (e, Equal, Expr.zero_i) + | BinOp (BinOp (a, FTimes, b), FMod, c) + when Expr.equal a c || Expr.equal b c -> Expr.num 0. + | BinOp (x, FTimes, BinOp (y, FDiv, z)) when x = z -> f y + | BinOp (BinOp (x, FDiv, y), FTimes, z) when y = z -> f x + | BinOp (UnOp (NumToInt, x), Equal, y) | BinOp (y, Equal, UnOp (NumToInt, x)) + -> BinOp (UnOp (IntToNum, y), Equal, x) + (* BinOps: Equalities (strings) *) + (* x = y ++ z + /\ |x| < |y| => false + /\ |x| = |y| => x = y /\ z = "" + /\ |x| > |y| => x[0..|y|] = y /\ x[|y|..] = z *) + | BinOp (Lit (String ls), Equal, BinOp (Lit (String rs), StrCat, s)) + | BinOp (BinOp (Lit (String rs), StrCat, s), Equal, Lit (String ls)) -> ( + let lls = String.length ls in + let lrs = String.length rs in + match Stdlib.compare lls lrs with + | -1 -> Expr.false_ + | 0 when ls <> rs -> Expr.false_ + | 0 -> BinOp (s, Equal, Lit (String "")) + | 1 when not (String.starts_with ~prefix:rs ls) -> Expr.false_ + | 1 -> BinOp (s, Equal, Lit (String (String.sub ls lrs (lls - lrs)))) + | _ -> raise (Exceptions.Impossible "int comparison not in {-1, 0, 1}")) + (* a ++ b = a ++ c <=> b = c *) + | BinOp (BinOp (sl1, StrCat, sr1), Equal, BinOp (sl2, StrCat, sr2)) + when sl1 = sl2 -> BinOp (sr1, Equal, sr2) + | BinOp (BinOp (sl1, StrCat, sr1), Equal, BinOp (sl2, StrCat, sr2)) + when sr1 = sr2 -> BinOp (sl1, Equal, sl2) + (* a ++ b = a <=> b = "" *) + | BinOp (BinOp (sl, StrCat, sr), Equal, s) when sl = s -> + BinOp (sr, Equal, Lit (String "")) + | BinOp (BinOp (sl, StrCat, sr), Equal, s) when sr = s -> + BinOp (sl, Equal, Lit (String "")) + | BinOp (s, Equal, BinOp (sl, StrCat, sr)) when sl = s -> + BinOp (sr, Equal, Lit (String "")) + | BinOp (s, Equal, BinOp (sl, StrCat, sr)) when sr = s -> + BinOp (sl, Equal, Lit (String "")) + | BinOp (BinOp (sl, StrCat, sr), Equal, Lit (String "")) -> + BinOp + ( BinOp (sl, Equal, Lit (String "")), + And, + BinOp (sr, Equal, Lit (String "")) ) + (* by injectivity *) + | BinOp (UnOp (ToStringOp, le1), Equal, UnOp (ToStringOp, le2)) -> + BinOp (le1, Equal, le2) + | BinOp (UnOp (ToStringOp, le1), Equal, Lit (String s)) + | BinOp (Lit (String s), Equal, UnOp (ToStringOp, le1)) -> ( + match s with + | "" -> Expr.false_ + | "Infinity" | "-Infinity" | "NaN" -> le + | _ -> ( + try Expr.BinOp (le1, Equal, Lit (Num (Float.of_string s))) + with _ -> Expr.false_)) + (* BinOps: Equalities (Empty?) *) + | BinOp (Lit Empty, Equal, e) | BinOp (e, Equal, Lit Empty) -> ( + match e with + | Lit l when l <> Empty -> Expr.false_ + | EList _ | ESet _ -> Expr.false_ + | _ -> le) + | BinOp (Lit l1, Equal, Lit l2) -> Expr.bool (l1 = l2) + (* JOSE: Why are we considering the case of a logical variable being bound to None? *) + | BinOp (Lit Nono, Equal, LVar x) | BinOp (LVar x, Equal, Lit Nono) -> ( + match Type_env.get gamma x with + | None | Some NoneType -> le + | _ -> Expr.false_) + | BinOp (Lit Nono, Equal, _) | BinOp (_, Equal, Lit Nono) -> Expr.false_ + (* BinOps: Equalities (typing) *) + (* Can this be generalised? add an fn to typing, that maps BinOp -> ret type *) + | BinOp (UnOp (TypeOf, BinOp (_, StrCat, _)), Equal, Lit (Type t)) + when t <> StringType -> Expr.false_ + | BinOp (UnOp (TypeOf, BinOp (_, SetMem, _)), Equal, Lit (Type t)) + when t <> BooleanType -> Expr.false_ + (* BinOps: Logic *) + | BinOp (Lit (Bool true), And, e) + | BinOp (e, And, Lit (Bool true)) + | BinOp (Lit (Bool false), Or, e) + | BinOp (e, Or, Lit (Bool false)) + | BinOp (Lit (Bool true), Impl, e) -> e + | BinOp (Lit (Bool false), And, _) | BinOp (_, And, Lit (Bool false)) -> + Expr.false_ + | BinOp (Lit (Bool true), Or, _) + | BinOp (_, Or, Lit (Bool true)) + | BinOp (Lit (Bool false), Impl, _) + | BinOp (_, Impl, Lit (Bool true)) -> Expr.true_ + | BinOp (left, Impl, Lit (Bool false)) -> UnOp (Not, left) + | BinOp (left, Impl, right) -> ( + let left = f left in + match Expr.as_boolean_expr left with + | None -> BinOp (left, Impl, f right) + | Some (Lit (Bool true), _) -> f right + | Some (Lit (Bool false), _) -> Expr.true_ + | Some (left_f, _) -> + let pfs_with_left = PFS.copy pfs in + PFS.extend pfs_with_left left_f; + let right = + reduce_lexpr_loop ~matching ~reduce_lvars pfs_with_left gamma + right + in + BinOp (left, Impl, right)) + (* BinOps: List indexing *) + | BinOp (le, LstNth, idx) -> ( + let fle = f le in + let fidx = f idx in + match fidx with + (* Index is a non-negative integer *) + | Lit (Int n) when Z.leq Z.zero n -> + if lexpr_is_list gamma fle then + Option.value + ~default:(Expr.BinOp (fle, LstNth, fidx)) + (get_nth_of_list pfs fle (Z.to_int n)) + else + let err_msg = + Fmt.str "LstNth(%a, %a): list is not a GIL list." Expr.pp fle + Expr.pp idx in - match t with - | Some t -> Type_env.update new_gamma x t - | None -> Type_env.remove new_gamma x) - bt + L.normal (fun fmt -> fmt "%s" err_msg); + raise (ReductionException (BinOp (fle, LstNth, fidx), err_msg)) + (* Index is a number, but is either not an integer or is negative *) + | Lit (Int _) | Lit (Num _) -> + let err_msg = + "LstNth(list, index): index is smaller than zero or a float." + in + raise (ReductionException (BinOp (fle, LstNth, fidx), err_msg)) + (* All other cases *) + | _ -> BinOp (fle, LstNth, fidx)) + | BinOp (x, LstRepeat, Lit (Int i)) when Z.lt i (Z.of_int 100) -> + let fx = f x in + let result = List.init (Z.to_int i) (fun _ -> fx) in + EList result + (* BinOps: String indexing *) + | BinOp (le, StrNth, idx) -> ( + let fle = f le in + let fidx = f idx in + match fidx with + (* Index is a non-negative integer *) + | Lit (Num n) when Arith_utils.is_int n && 0. <= n -> ( + match lexpr_is_string gamma fle with + | true -> + Option.value + ~default:(Expr.BinOp (fle, StrNth, fidx)) + (get_nth_of_string fle (int_of_float n)) + | false -> + let err_msg = + "StrNth(str, index): string is not a GIL string." + in + raise + (ReductionException (Expr.BinOp (fle, StrNth, fidx), err_msg)) + ) + (* Index is a number, but is either not an integer or is negative *) + | Lit (Num _) -> + let err_msg = + "StrNth(str, index): index is non-integer or smaller than zero." + in + raise (ReductionException (Expr.BinOp (fle, StrNth, fidx), err_msg)) + (* All other cases *) + | _ -> BinOp (fle, StrNth, fidx)) + (* BinOps: Maths *) + | BinOp (Lit (Int z), ILessThanEqual, UnOp (LstLen, _)) + when Z.equal z Z.zero -> Expr.true_ + (* x < y /\ (y <= x \/ y < x) <=> false *) + | BinOp (e1, FLessThan, e2) + when PFS.mem pfs (BinOp (e2, FLessThanEqual, e1)) + || PFS.mem pfs (BinOp (e2, FLessThan, e1)) -> Expr.false_ + | BinOp (e1, ILessThan, e2) + when PFS.mem pfs (BinOp (e2, ILessThanEqual, e1)) + || PFS.mem pfs (BinOp (e2, ILessThan, e1)) -> Expr.false_ + (* x <= y /\ y < x <=> false *) + | BinOp (e1, FLessThanEqual, e2) + when PFS.mem pfs (BinOp (e2, FLessThan, e1)) -> Expr.false_ + | BinOp (e1, ILessThanEqual, e2) + when PFS.mem pfs (BinOp (e2, ILessThan, e1)) -> Expr.false_ + (* x <= y /\ x < y <=> true *) + | BinOp (e1, FLessThanEqual, e2) + when PFS.mem pfs (BinOp (e1, FLessThan, e2)) -> Expr.true_ + | BinOp (e1, ILessThanEqual, e2) + when PFS.mem pfs (BinOp (e1, ILessThan, e2)) -> Expr.true_ + (* x <= y /\ y <= x <=> x = y *) + | BinOp (e1, ((FLessThanEqual | ILessThanEqual) as op), e2) + when PFS.mem pfs (BinOp (e2, op, e1)) -> BinOp (e1, Equal, e2) + (* BinOps: set operations *) + | BinOp (_, SetMem, NOp ((SetUnion | SetInter), [])) -> Expr.false_ + | BinOp (leb, SetMem, NOp (((SetUnion | SetInter) as op), le :: lle)) -> + let bop : BinOp.t = if op = SetUnion then Or else And in + let rle = f le in + let rleb = f leb in + List.fold_left + (fun ac le -> + let rle = f le in + Expr.BinOp (ac, bop, BinOp (rleb, SetMem, rle))) + (Expr.BinOp (rleb, SetMem, rle)) + lle + | BinOp (leb, SetMem, BinOp (lel, SetDiff, ler)) -> + let rleb = f leb in + let rlel = f lel in + let rler = f ler in + BinOp + ( BinOp (rleb, SetMem, rlel), + And, + UnOp (Not, BinOp (rleb, SetMem, rler)) ) + | BinOp (leb, SetMem, ESet les) -> + let rleb = f leb in + let rles = List.map f les in + let result = List.map (fun le -> Expr.BinOp (rleb, Equal, le)) rles in + Expr.disjunct result + (* CHECK: FTimes and Div are the same, how does the 'when' scope? *) + | BinOp (lel, op, ler) -> ( + let open Syntaxes.Option in + (* If we're reducing A || B or A && B and either side have a reduction exception, it must be false *) + let flel, fler, exn = + try (f lel, f ler, false) with + | ReductionException _ when op = Or || op = And -> + (Expr.false_, Expr.false_, true) + | exn -> raise exn in - let () = PFS.substitution subst new_pfs in - (* We reduce using our new pfs and gamma *) - let re = - reduce_lexpr_loop ~matching ~reduce_lvars new_pfs new_gamma e + let- () = if exn then Some Expr.false_ else None in + let def = Expr.BinOp (flel, op, fler) in + let- () = + match (flel, fler) with + | (Lit _ as ll), (Lit _ as lr) -> ( + try + let lit = CExprEval.evaluate_binop (CStore.init []) op ll lr in + Some (Expr.Lit lit) + with + | CExprEval.TypeError err_msg -> + raise (ReductionException (def, err_msg)) + | CExprEval.EvaluationError err_msg -> + raise (ReductionException (def, err_msg)) + | e -> raise e) + | _ -> None in - let vars = Expr.lvars re in - let bt = List.filter (fun (b, _) -> Containers.SS.mem b vars) bt in - (* We remove all quantifiers that aren't used anymore *) - match (le, bt) with - | _, [] -> re - | ForAll _, _ -> ForAll (bt, re) - | Exists _, _ -> Exists (bt, re) - | _, _ -> failwith "Impossible.") - (* The remaining cases cannot be reduced *) - | PVar _ | LVar _ | ALoc _ -> le + let- () = + reduce_binop_inttonum_const matching reduce_lvars pfs gamma flel fler + op + in + match op with + | Equal -> ( + let- () = + if Expr.equal flel fler then Some Expr.true_ + else if + PFS.exists + (fun e -> + Expr.equal e (BinOp (flel, Equal, fler)) + || Expr.equal e (BinOp (fler, Equal, flel))) + pfs + then Some Expr.true_ + else if + PFS.mem pfs (UnOp (Not, BinOp (flel, Equal, fler))) + || PFS.mem pfs (UnOp (Not, BinOp (fler, Equal, flel))) + then Some Expr.false_ + else None + in + (* TODO: Here we don't use the 2nd param, is that ok? *) + let t1, _ = Typing.type_lexpr gamma flel in + let t2, _ = Typing.type_lexpr gamma fler in + let- () = + match (t1, t2) with + | Some t1, Some t2 when t1 <> t2 -> Some Expr.false_ + | _, _ -> None + in + match (flel, fler) with + (* "RPFS" only? whatever that meant it's here now. *) + | NOp (LstCat, _), LVar y when (* rpfs && *) prefix_catch pfs flel y + -> BinOp (UnOp (LstLen, flel), Equal, UnOp (LstLen, fler)) + (* Lists *) + | EList [], x | x, EList [] | Lit (LList []), x | x, Lit (LList []) + -> ( + match x with + | Lit (LList (_ :: _)) | EList (_ :: _) -> Expr.false_ + | NOp (LstCat, les) + when List.exists + (function + | Expr.EList (_ :: _) | Lit (LList (_ :: _)) -> true + | _ -> false) + les -> Expr.false_ + | _ -> def) + (* Booleans *) + | Lit (Bool true), _ when t2 = Some Type.BooleanType -> fler + | _, Lit (Bool true) when t1 = Some Type.BooleanType -> flel + (* Nested equalities *) + | Lit (Bool b), (BinOp (_, Equal, _) as e) + | (BinOp (_, Equal, _) as e), Lit (Bool b) + | Lit (Bool b), UnOp (Not, (BinOp (_, Equal, _) as e)) + | UnOp (Not, (BinOp (_, Equal, _) as e)), Lit (Bool b) -> + if b then e else UnOp (Not, e) + (* For two non-LVar lists l1 = h1::tl1, l2 = h2::tl2 + l1 = l2 <=> h1 = h2 /\ tl1 = tl2 + The two 'false' cases are if we can't get the head/tail of a list + while it is a LList/EList, meaning it's definitely empty. + These two cases are likely to have been caught before but who knows. *) + | _, _ + when (match (flel, fler) with + | LVar _, _ | _, LVar _ -> false + | _ -> true) + && lexpr_is_list gamma flel && lexpr_is_list gamma fler -> ( + let htl1, htl2 = + ( get_head_and_tail_of_list ~pfs flel, + get_head_and_tail_of_list ~pfs fler ) + in + match (htl1, htl2, flel, fler) with + | Some (hl1, tl1), Some (hl2, tl2), _, _ -> + BinOp (BinOp (hl1, Equal, hl2), And, BinOp (tl1, Equal, tl2)) + | None, Some _, (Lit (LList _) | EList _), _ -> Expr.false_ + | Some _, None, _, (Lit (LList _) | EList _) -> Expr.false_ + | _ -> def) + (* FPlus theory -> theory? I would not go that far *) + | _, _ when lexpr_is_number flel && lexpr_is_number fler -> + let success, le1', le2' = Cnum.cut flel fler in + if success then BinOp (le1', Equal, le2') else def + | le1, le2 when lexpr_is_int le1 && lexpr_is_int le2 -> + let success, le1', le2' = Cint.cut le1 le2 in + if success then BinOp (le1', Equal, le2') else def + | _, _ -> def) + | (FPlus | FMinus) when lexpr_is_number ~gamma def -> + simplify_num_arithmetic_lexpr pfs gamma def + | (IPlus | IMinus) when lexpr_is_int ~gamma def -> + simplify_int_arithmetic_lexpr pfs gamma def + | FTimes when lexpr_is_number ~gamma def -> ( + match (flel, fler) with + (* 1 is the neutral *) + | Lit (Num 1.), x | x, Lit (Num 1.) -> x + | Lit (Num x), _ when x == nan -> Lit (Num nan) + | _, Lit (Num x) when x == nan -> Lit (Num nan) + | BinOp (Lit (Num x), FTimes, y), Lit (Num z) + | Lit (Num z), BinOp (Lit (Num x), FTimes, y) -> + BinOp (Lit (Num (z *. x)), FTimes, y) + (* Rest *) + | _, _ -> def) + | ITimes when lexpr_is_int ~gamma def -> ( + match (flel, fler) with + | Lit (Int z), x when Z.equal z Z.one -> x + | x, Lit (Int z) when Z.equal z Z.one -> x + | (Lit (Int z) as zero), _ when Z.equal z Z.zero -> zero + | _, (Lit (Int z) as zero) when Z.equal z Z.zero -> zero + | BinOp (Lit (Int x), ITimes, y), Lit (Int z) + | Lit (Int z), BinOp (Lit (Int x), ITimes, y) -> + BinOp (Lit (Int (Z.mul z x)), ITimes, y) + | _, _ -> def) + | FDiv when lexpr_is_number ~gamma def -> ( + match (flel, fler) with + (* 1 is the neutral *) + | x, Lit (Num 1.) -> x + | _, _ -> def) + | IDiv when lexpr_is_int ~gamma def -> ( + match (flel, fler) with + | x, Lit (Int o) when Z.equal o Z.one -> x + | _, _ -> def) + | And when lexpr_is_bool gamma def -> ( + match (flel, fler) with + (* 1 is the neutral *) + | Lit (Bool true), x | x, Lit (Bool true) -> x + | Lit (Bool false), _ | _, Lit (Bool false) -> Lit (Bool false) + (* Rest *) + | _, _ -> + let fal, nfal = Option.get @@ Expr.as_boolean_expr flel in + let far, nfar = Option.get @@ Expr.as_boolean_expr fler in + if PFS.mem pfs nfal || PFS.mem pfs nfar then Lit (Bool false) + else if PFS.mem pfs fal then f fler + else if PFS.mem pfs far then f flel + else BinOp (flel, And, fler)) + | Or when lexpr_is_bool gamma def -> ( + match (flel, fler) with + (* 1 is the neutral *) + | Lit (Bool true), _ | _, Lit (Bool true) -> Lit (Bool true) + | Lit (Bool false), x | x, Lit (Bool false) -> x + (* Rest *) + | _, _ -> + let fal, nfal = Option.get @@ Expr.as_boolean_expr flel in + let far, nfar = Option.get @@ Expr.as_boolean_expr fler in + if PFS.mem pfs fal || PFS.mem pfs far then Lit (Bool true) + else if PFS.mem pfs nfal then f fler + else if PFS.mem pfs nfar then f flel + else BinOp (flel, Or, fler)) + | StrCat when lexpr_is_string gamma def -> ( + match (flel, fler) with + (* Empty list is the neutral *) + | x, Lit (String "") | Lit (String ""), x -> x + (* Rest *) + | BinOp (el, StrCat, Lit (String s1)), Lit (String s2) -> + f (BinOp (el, StrCat, Lit (String (s1 ^ s2)))) + | _, _ -> def) + | SetDiff when lexpr_is_set gamma def -> ( + let pfs = PFS.to_list pfs in + if contained_in_union pfs flel fler then ESet [] + else + match (flel, fler) with + | x, y when x = y -> ESet [] + | ESet [], _ -> ESet [] + | x, ESet [] -> x + | ESet left, ESet right + when Expr.all_literals left && Expr.all_literals right -> + ESet + (Expr.Set.elements + (Expr.Set.diff (Expr.Set.of_list left) + (Expr.Set.of_list right))) + | ESet left, s when Expr.all_literals left -> + if List.for_all (fun x -> set_member pfs x s) left then + ESet [] + else def + | ESet left, ESet right -> + L.verbose (fun fmt -> fmt "Inside relevant SetDiff case."); + let candidate_result = + Expr.Set.elements + (Expr.Set.diff (Expr.Set.of_list left) + (Expr.Set.of_list right)) + in + L.verbose (fun fmt -> + fmt "Candidate result: %a" + Fmt.(brackets (list ~sep:comma Expr.pp)) + candidate_result); + let result = + if + List.for_all + (fun x -> not_set_member pfs x (ESet right)) + candidate_result + then Expr.ESet candidate_result + else def + in + L.verbose (fun fmt -> fmt "Actual result: %a" Expr.pp result); + result + | NOp (SetUnion, les), _ -> + let diffs = + List.map (fun le -> f (BinOp (le, SetDiff, fler))) les + in + NOp (SetUnion, diffs) + | _, NOp (SetUnion, les) -> + f + (NOp + ( SetInter, + List.map (fun le -> Expr.BinOp (flel, SetDiff, le)) les + )) + | x, ESet [ el ] + when List.mem (Expr.UnOp (Not, BinOp (el, SetMem, x))) pfs -> x + | LVar _, _ -> if set_subset pfs flel fler then ESet [] else def + | ESet les, fler -> ( + (* We must know that the elements of les are all different, and for that we need the pure formulae *) + match all_different pfs les with + | false -> def + | true -> + let _, rest = + List.partition (fun x -> set_member pfs x fler) les + in + if List.for_all (fun x -> not_set_member pfs x fler) rest + then ESet rest + else BinOp (ESet rest, SetDiff, fler)) + | _, _ -> def) + (* let hM = f (BinOp (flel, SetSub, fler)) in + (match hM with + | Lit (Bool true) -> ESet [] + | _ -> def)) *) + | SetMem when lexpr_is_bool gamma def -> ( + match (flel, fler) with + | _, ESet [] -> Lit (Bool false) + | _, ESet [ x ] -> BinOp (flel, Equal, x) + | le, ESet les -> ( + match List.mem le les with + | true -> Lit (Bool true) + | false -> ( + match le with + | Lit _ -> + if Expr.all_literals les then Lit (Bool false) else def + | _ -> def)) + | _, _ -> def) + | SetSub when lexpr_is_bool gamma def -> ( + match (flel, fler) with + | ESet [], _ -> Lit (Bool true) + | _, ESet [] -> Lit (Bool false) + | ESet left, ESet right + when Expr.all_literals left && Expr.all_literals right -> + Lit + (Bool + (Expr.Set.subset (Expr.Set.of_list left) + (Expr.Set.of_list right))) + | LVar _, NOp (SetUnion, les) -> + if List.mem flel les then Lit (Bool true) else def + | _, _ -> def) + | FLessThan -> + let success, el, er = Cnum.cut flel fler in + let nexpr = Expr.BinOp (el, FLessThan, er) in + if success then f nexpr else nexpr + | ILessThan -> ( + match (flel, fler) with + | x, fler + when let fler_len = substitute_for_list_length pfs fler in + match fler_len with + | UnOp (LstLen, _) -> true + | _ -> false -> + f + (BinOp + (BinOp (x, IPlus, Lit (Int Z.one)), ILessThanEqual, fler)) + | UnOp (LstLen, _), Lit (Int n) when Z.leq n Z.zero -> + Lit (Bool false) + | UnOp (LstLen, le), Lit (Int z) when Z.equal z Z.one -> + BinOp (le, Equal, EList []) + | _ -> + let _, el, er = Cint.cut flel fler in + Expr.BinOp (el, ILessThan, er) + (* if success then f nexpr else nexpr *) + (* | _, _ -> + f + (BinOp + (BinOp (flel, FMinus, fler), FLessThan, Lit (Num 0.))) *) + ) + | FLessThanEqual -> ( + let success, el, er = Cnum.cut flel fler in + if success then BinOp (el, FLessThanEqual, er) + else + match + check_ge_zero_num ~top_level:true pfs + (f (BinOp (fler, FMinus, flel))) + with + | Some x -> Lit (Bool x) + | None -> def) + | ILessThanEqual -> ( + let success, el, er = Cint.cut flel fler in + if success then BinOp (el, ILessThanEqual, er) + else + match + check_ge_zero_int ~top_level:true pfs + (f (BinOp (fler, IMinus, flel))) + with + | Some x -> Lit (Bool x) + | None -> def) + | _ -> def) in - let result = normalise_list_expressions result in - if not (Expr.equal le result) then ( + if Expr.equal le result then result + else ( L.tmi (fun m -> m "\tReduce_lexpr: %a -> %a" Expr.pp le Expr.pp result); f result) - else result and reduce_lexpr ?(matching = false) @@ -2134,8 +2362,7 @@ and check_ge_zero_int ?(top_level = false) (pfs : PFS.t) (e : Expr.t) : | UnOp (LstLen, _) | UnOp (StrLen, _) -> Some true | (LVar _ | PVar _) when not top_level -> if - List.exists - (fun pf -> PFS.mem pfs pf) + List.exists (PFS.mem pfs) [ Expr.BinOp (Expr.zero_i, ILessThanEqual, e); Expr.BinOp (Expr.zero_i, ILessThan, e); @@ -2456,547 +2683,15 @@ let resolve_expr_to_location (pfs : PFS.t) (gamma : Type_env.t) (e : Expr.t) : in resolve_expr_to_location_aux max_fuel Expr.Set.empty [ e ] -let rec reduce_formula_loop - ?(top_level = false) - ?(rpfs = false) - (matching : bool) - (pfs : PFS.t) - (gamma : Type_env.t) - ?(previous = Expr.Lit (Bool true)) - (a : Expr.t) : Expr.t = - Logging.tmi (fun m -> - m "Reduce formula: %a -> %a" - (fun ft f -> - match f with - | Expr.Lit (Bool true) -> - Fmt.pf ft "STARTING TO REDUCE: matching %b, rpfs %b" matching rpfs - | _ -> Expr.pp ft f) - previous Expr.pp a); - if Expr.equal a previous then - let () = - Logging.tmi (fun m -> m "Finished reducing, obtained: %a" Expr.pp a) - in - a - else - let f = reduce_formula_loop ~rpfs matching pfs gamma in - let fe = reduce_lexpr_loop ~matching pfs gamma in - let result : Expr.t = - match a with - | BinOp (e1, Equal, e2) when Expr.equal e1 e2 -> Expr.true_ - (* DEDICATED SIMPLIFICATIONS - this should probably be handled properly by SMT... *) - | BinOp (BinOp (Lit (Num x), FPlus, LVar y), Equal, LVar z) - when x <> 0. && String.equal y z -> Expr.false_ - | BinOp (BinOp (Lit (Int x), IPlus, LVar y), Equal, LVar z) - when (not (Z.equal x Z.zero)) && String.equal y z -> Expr.false_ - | ForAll - ( [ (x, Some IntType) ], - BinOp - ( BinOp - ( BinOp (LVar a, ILessThan, Lit (Int z)), - Or, - BinOp (Lit (Int len), ILessThanEqual, LVar b) ), - Or, - BinOp (BinOp (EList c, LstNth, LVar d), Equal, e) ) ) - when Z.equal z Z.zero && String.equal x a && String.equal a b - && String.equal b d - && Int.equal (List.compare_length_with c (Z.to_int len)) 0 -> - let rhs = Expr.EList (List_utils.make (Z.to_int len) e) in - BinOp (EList c, Equal, rhs) - (* FIXME: INTEGER BYTE-BY-BYTE BREAKDOWN *) - | BinOp - ( Lit (Int n), - Equal, - BinOp (BinOp (Lit (Int tfs), ITimes, LVar b1), IPlus, LVar b0) ) - when top_level && Z.equal tfs _256 - && PFS.mem pfs (BinOp (Expr.zero_i, ILessThanEqual, LVar b0)) - && PFS.mem pfs (BinOp (Expr.zero_i, ILessThanEqual, LVar b1)) - && PFS.mem pfs (BinOp (LVar b0, ILessThan, Lit (Int _256))) - && PFS.mem pfs (BinOp (LVar b1, ILessThan, Lit (Int _256))) -> - if Z.gt n _65535 then Expr.false_ - else - let vb1 = Z.div n _256 in - let vb0 = Z.sub n vb1 in - Expr.BinOp - ( BinOp (LVar b1, Equal, Lit (Int vb1)), - And, - BinOp (LVar b0, Equal, Lit (Int vb0)) ) - | BinOp - ( BinOp (BinOp (Lit (Int tfs), ITimes, LVar b1), IPlus, LVar b0), - Equal, - Lit (Int n) ) - when top_level && Z.equal tfs _256 - && PFS.mem pfs (BinOp (Expr.zero_i, ILessThanEqual, LVar b0)) - && PFS.mem pfs (BinOp (Expr.zero_i, ILessThanEqual, LVar b1)) - && PFS.mem pfs (BinOp (LVar b0, ILessThan, Lit (Int _256))) - && PFS.mem pfs (BinOp (LVar b1, ILessThan, Lit (Int _256))) -> - if Z.gt n _65535 then Expr.false_ - else - let vb1 = Z.div n _256 in - let vb0 = Z.sub n vb1 in - BinOp - ( BinOp (LVar b1, Equal, Lit (Int vb1)), - And, - BinOp (LVar b0, Equal, Lit (Int vb0)) ) - | BinOp (BinOp (e, FTimes, Lit (Num x)), Equal, Lit (Num 0.)) when x <> 0. - -> BinOp (e, Equal, Lit (Num 0.)) - | BinOp (BinOp (Lit (Num x), FTimes, e), Equal, Lit (Num 0.)) when x <> 0. - -> BinOp (e, Equal, Lit (Num 0.)) - | BinOp (BinOp (e, ITimes, Lit (Int x)), Equal, Lit (Int n)) - when Z.equal n Z.zero && not (Z.equal x Z.zero) -> - BinOp (e, Equal, Expr.zero_i) - | BinOp (BinOp (Lit (Int x), ITimes, e), Equal, Lit (Int n)) - when Z.equal n Z.zero && not (Z.equal x Z.zero) -> - BinOp (e, Equal, Expr.zero_i) - | BinOp (Lit (LList ll), Equal, Lit (LList lr)) -> Expr.bool (ll = lr) - | BinOp (EList le, Equal, Lit (LList ll)) - | BinOp (Lit (LList ll), Equal, EList le) -> - if List.length ll <> List.length le then Expr.false_ - else if ll = [] then Expr.true_ - else - let eqs = - List.map2 (fun x y -> Expr.BinOp (x, Equal, Lit y)) le ll - in - let conj = Expr.conjunct eqs in - conj - | BinOp (EList ll, Equal, EList lr) -> - if List.length ll <> List.length lr then Expr.false_ - else if ll = [] then Expr.true_ - else - let eqs = List.map2 (fun x y -> Expr.BinOp (x, Equal, y)) ll lr in - let conj = Expr.conjunct eqs in - conj - | BinOp (left_list, Equal, right_list) - when (match - ( Typing.type_lexpr gamma left_list, - Typing.type_lexpr gamma right_list ) - with - | (Some Type.ListType, _), (Some Type.ListType, _) -> true - | _ -> false) - && - match - fe - (Expr.Infix.( - ) - (Expr.list_length left_list) - (Expr.list_length right_list)) - with - | Expr.Lit (Int k) when not (Z.equal k Z.zero) -> true - | _ -> false -> - (* If we have two lists but can reduce the equality of their lengths to false, - then we know the lists cannot be equal*) - Expr.false_ - | BinOp (NOp (LstCat, les), Equal, LVar x) - when List.mem (Expr.LVar x) les - && List.exists - (fun e -> - match e with - | Expr.EList (_ :: _) | Lit (LList (_ :: _)) -> true - | _ -> false) - les -> Expr.false_ - | BinOp (UnOp (NumToInt, le), Equal, re) -> - BinOp (le, Equal, UnOp (IntToNum, re)) - | BinOp (le, Equal, UnOp (NumToInt, re)) -> - BinOp (UnOp (IntToNum, le), Equal, re) - | BinOp (a1, And, a2) -> - let fa1 = f a1 in - let fa2 = f a2 in - Expr.Infix.( && ) fa1 fa2 - | BinOp (a1, Or, a2) -> ( - let fa1 = f a1 in - let fa2 = f a2 in - match (fa1, fa2) with - | Expr.Lit (Bool false), a | a, Expr.Lit (Bool false) -> a - | Expr.Lit (Bool true), _ | _, Expr.Lit (Bool true) -> - Expr.Lit (Bool true) - | _, _ -> - if PFS.mem pfs fa1 || PFS.mem pfs fa2 then Expr.Lit (Bool true) - else if PFS.mem pfs (UnOp (Not, fa1)) then fa2 - else if PFS.mem pfs (UnOp (Not, fa2)) then fa1 - else BinOp (fa1, Or, fa2)) - (* JOSE: why the recursive call? *) - | UnOp (Not, a) -> ( - let fa = f a in - match a with - | Lit (Bool b) -> Lit (Bool (not b)) - | UnOp (Not, a) -> a - | BinOp (a1, Or, a2) -> BinOp (UnOp (Not, a1), And, UnOp (Not, a2)) - | BinOp (a1, And, a2) -> BinOp (UnOp (Not, a1), Or, UnOp (Not, a2)) - | BinOp (e1, FLessThan, e2) -> BinOp (e2, FLessThanEqual, e1) - | BinOp (e1, FLessThanEqual, e2) -> BinOp (e2, FLessThan, e1) - | BinOp (e1, ILessThan, e2) -> BinOp (e2, ILessThanEqual, e1) - | BinOp (e1, ILessThanEqual, e2) -> BinOp (e2, ILessThan, e1) - | _ -> UnOp (Not, fa)) - | BinOp (e1, Equal, e2) -> ( - let re1 = fe e1 in - let re2 = fe e2 in - (* Warning - NaNs, infinities, this and that, this is not good enough *) - let eq = re1 = re2 in - if eq then Expr.true_ - else - let t1, s1 = Typing.type_lexpr gamma re1 in - let t2, s2 = Typing.type_lexpr gamma re2 in - if - s1 && s2 - && - match (t1, t2) with - | Some t1, Some t2 -> t1 <> t2 - | _, _ -> false - then Expr.false_ - else - let ite a b = Expr.bool (a = b) in - let default re1 re2 = Expr.BinOp (re1, Equal, re2) in - match (re1, re2) with - (* DEDICATED RPFS REDUCTIONS *) - | NOp (LstCat, _), LVar y when rpfs && prefix_catch pfs re1 y -> - BinOp (UnOp (LstLen, re1), Equal, UnOp (LstLen, re2)) - | LVar x, NOp (LstCat, LstSub (y, UnOp (LstLen, z), len) :: t) - when rpfs - && PFS.mem pfs - (BinOp - ( NOp (LstCat, y :: t), - Equal, - NOp (LstCat, [ z; LVar x ]) )) - && Cint.canonicalise len - = Cint.canonicalise - (BinOp (UnOp (LstLen, y), IMinus, UnOp (LstLen, z))) - -> Expr.true_ - (* USUAL REDUCTIONS *) - | ALoc _, Lit (Loc _) | Lit (Loc _), ALoc _ -> Expr.false_ - | ALoc x, ALoc y when (not matching) && x <> y -> Expr.false_ - | EList [], x - | x, EList [] - | Lit (LList []), x - | x, Lit (LList []) -> ( - match x with - | Lit (LList lst) when List.length lst > 0 -> Expr.false_ - | EList lst when List.length lst > 0 -> Expr.false_ - | NOp (LstCat, les) - when List.exists - (function - | Expr.EList (_ :: _) | Lit (LList (_ :: _)) -> - true - | _ -> false) - les -> Expr.false_ - | _ -> BinOp (re1, Equal, re2)) - (* Lifting *) - | Lit (Bool true), _ when t2 = Some Type.BooleanType -> re2 - | _, Lit (Bool true) when t1 = Some Type.BooleanType -> re1 - | Lit (Bool true), BinOp (x, Equal, y) - | BinOp (x, Equal, y), Lit (Bool true) - | Lit (Bool false), UnOp (Not, BinOp (x, Equal, y)) - | UnOp (Not, BinOp (x, Equal, y)), Lit (Bool false) -> - BinOp (x, Equal, y) - | Lit (Bool true), UnOp (Not, BinOp (x, Equal, y)) - | UnOp (Not, BinOp (x, Equal, y)), Lit (Bool true) - | Lit (Bool false), BinOp (x, Equal, y) - | BinOp (x, Equal, y), Lit (Bool false) -> - UnOp (Not, BinOp (x, Equal, y)) - | UnOp (LstRev, ll), UnOp (LstRev, rl) -> BinOp (ll, Equal, rl) - (* TODO: This is a specialised simplification, not sure for what, disabled for now - | UnOp (LstRev, full_list), BinOp (UnOp (LstRev, plist_left), LstCat, plist_right) - | BinOp (UnOp (LstRev, plist_left), LstCat, plist_right), UnOp (LstRev, full_list) - -> - f (Eq (full_list, BinOp (UnOp (LstRev, plist_right), LstCat, plist_left))) *) - | LstSub (e1, Lit (Int z), el), e2 - when Z.equal z Z.zero && Expr.equal e1 e2 -> - BinOp (UnOp (LstLen, e1), Equal, el) - | e2, LstSub (e1, Lit (Int z), el) - when Z.equal z Z.zero && Expr.equal e1 e2 -> - BinOp (UnOp (LstLen, e1), Equal, el) - | e2, LstSub (NOp (LstCat, e1 :: _), Lit (Int z), el) - when Z.equal z Z.zero && Expr.equal e1 e2 -> - BinOp (UnOp (LstLen, e1), Equal, el) - | LstSub (NOp (LstCat, e1 :: _), Lit (Int z), el), e2 - when Z.equal z Z.zero && Expr.equal e1 e2 -> - BinOp (UnOp (LstLen, e1), Equal, el) - | e2, LstSub (NOp (LstCat, e3 :: e1 :: _), ex, ey) - when Expr.equal e1 e2 -> - BinOp - ( BinOp (UnOp (LstLen, e3), Equal, ex), - And, - BinOp (UnOp (LstLen, e1), Equal, ey) ) - | LstSub (NOp (LstCat, e3 :: e1 :: _), ex, ey), e2 - when Expr.equal e1 e2 -> - BinOp - ( BinOp (UnOp (LstLen, e3), Equal, ex), - And, - BinOp (UnOp (LstLen, e1), Equal, ey) ) - | NOp (LstCat, fl :: rl), NOp (LstCat, fr :: rr) - when Expr.equal fl fr -> - BinOp (NOp (LstCat, rl), Equal, NOp (LstCat, rr)) - | NOp (LstCat, fl :: rl), NOp (LstCat, fr :: rr) - when Expr.equal - (List.hd (List.rev (fl :: rl))) - (List.hd (List.rev (fr :: rr))) -> - f - (BinOp - ( NOp (LstCat, List.rev (List.tl (List.rev (fl :: rl)))), - Equal, - NOp (LstCat, List.rev (List.tl (List.rev (fr :: rr)))) - )) - | ( LVar lst, - NOp (LstCat, LstSub (LVar lst', Lit (Int z), split) :: _rest) - ) - when Z.equal z Z.zero && String.equal lst lst' - && PFS.mem pfs - (BinOp (UnOp (LstLen, LVar lst), ILessThan, split)) -> - Expr.false_ - | le1, le2 - when (match (le1, le2) with - | LVar _, _ | _, LVar _ -> false - | _ -> true) - && lexpr_is_list gamma le1 && lexpr_is_list gamma le2 -> ( - let htl1, htl2 = - ( get_head_and_tail_of_list ~pfs le1, - get_head_and_tail_of_list ~pfs le2 ) - in - match (htl1, htl2) with - | Some (hl1, tl1), Some (hl2, tl2) -> - BinOp - (BinOp (hl1, Equal, hl2), And, BinOp (tl1, Equal, tl2)) - | None, Some _ -> ( - match le1 with - | Lit (LList _) | EList _ -> Expr.false_ - | _ -> BinOp (re1, Equal, re2)) - | Some _, None -> ( - match le2 with - | Lit (LList _) | EList _ -> Expr.false_ - | _ -> BinOp (re1, Equal, re2)) - | None, None -> BinOp (re1, Equal, re2)) - (* Strings #1 *) - | Lit (String ls), BinOp (Lit (String rs), StrCat, s) - | BinOp (Lit (String rs), StrCat, s), Lit (String ls) -> ( - let lls = String.length ls in - let lrs = String.length rs in - match Stdlib.compare lls lrs with - | -1 -> Expr.false_ - | 0 -> - if ls <> rs then Expr.false_ - else BinOp (s, Equal, Lit (String "")) - | 1 -> - let sub = String.sub ls 0 lrs in - if sub <> rs then Expr.false_ - else - BinOp - ( s, - Equal, - Lit (String (String.sub ls lrs (lls - lrs))) ) - | _ -> - raise - (Exceptions.Impossible - "reduce_formula: string stuff: guaranteed by \ - match/filter")) - (* String #2 *) - | BinOp (sl1, StrCat, sr1), BinOp (sl2, StrCat, sr2) - when sl1 = sl2 -> BinOp (sr1, Equal, sr2) - | BinOp (sl1, StrCat, sr1), BinOp (sl2, StrCat, sr2) - when sr1 = sr2 -> BinOp (sl1, Equal, sl2) - (* String #3 *) - | BinOp (sl, StrCat, sr), s when sl = s -> - BinOp (sr, Equal, Lit (String "")) - | BinOp (sl, StrCat, sr), s when sr = s -> - BinOp (sl, Equal, Lit (String "")) - | s, BinOp (sl, StrCat, sr) when sl = s -> - BinOp (sr, Equal, Lit (String "")) - | s, BinOp (sl, StrCat, sr) when sr = s -> - BinOp (sl, Equal, Lit (String "")) - | BinOp (sl, StrCat, sr), Lit (String "") -> - BinOp - ( BinOp (sl, Equal, Lit (String "")), - And, - BinOp (sr, Equal, Lit (String "")) ) - (* Num-to-String injectivity *) - | UnOp (ToStringOp, le1), UnOp (ToStringOp, le2) -> - BinOp (le1, Equal, le2) - (* Num-to-String understanding *) - | UnOp (ToStringOp, le1), Lit (String s) - | Lit (String s), UnOp (ToStringOp, le1) -> ( - match s with - | "" -> Expr.false_ - | "Infinity" | "-Infinity" | "NaN" -> default re1 re2 - | _ -> ( - let num = try Some (Float.of_string s) with _ -> None in - match num with - | Some num -> BinOp (le1, Equal, Lit (Num num)) - | None -> Expr.false_)) - (* The empty business *) - | _, Lit Empty -> ( - match re1 with - | Lit l when l <> Empty -> Expr.false_ - | EList _ | ESet _ -> Expr.false_ - | _ -> default re1 re2) - | Lit l1, Lit l2 -> ite l1 l2 - | Lit Nono, PVar _ | PVar _, Lit Nono -> default re1 re2 - (* JOSE: Why are we considering the case of a logical variable being bound to None? *) - | Lit Nono, LVar x | LVar x, Lit Nono -> ( - let tx = Type_env.get gamma x in - match tx with - | None | Some NoneType -> default re1 re2 - | _ -> Expr.false_) - | Lit Nono, _ | _, Lit Nono -> Expr.false_ - | Lit (Bool true), BinOp (e1, FLessThan, e2) -> - BinOp (e1, FLessThan, e2) - | Lit (Bool false), BinOp (e1, FLessThan, e2) -> - BinOp (e2, FLessThanEqual, e1) - | Lit (Bool true), BinOp (e1, ILessThan, e2) -> - BinOp (e1, ILessThan, e2) - | Lit (Bool false), BinOp (e1, ILessThan, e2) -> - BinOp (e2, ILessThanEqual, e1) - (* FPlus theory -> theory? I would not go that far *) - | le1, le2 when lexpr_is_number le1 && lexpr_is_number le2 -> - let success, le1', le2' = Cnum.cut le1 le2 in - if success then BinOp (le1', Equal, le2') - else BinOp (le1, Equal, le2) - | le1, le2 when lexpr_is_int le1 && lexpr_is_int le2 -> - let success, le1', le2' = Cint.cut le1 le2 in - if success then BinOp (le1', Equal, le2') - else BinOp (le1, Equal, le2) - (* Very special cases *) - | UnOp (TypeOf, BinOp (_, StrCat, _)), Lit (Type t) - when t <> StringType -> Expr.false_ - | UnOp (TypeOf, BinOp (_, SetMem, _)), Lit (Type t) - when t <> BooleanType -> Expr.false_ - (* Set unions *) - | ( NOp (SetUnion, [ ls; ESet [ lx ] ]), - NOp (SetUnion, [ rs; ESet [ rx ] ]) ) - when lx = rx -> - if - PFS.mem pfs (UnOp (Not, BinOp (lx, SetMem, ls))) - && PFS.mem pfs (UnOp (Not, BinOp (lx, SetMem, rs))) - then BinOp (ls, Equal, rs) - else default re1 re2 - | _, _ -> default re1 re2) - | BinOp (Lit (Int z), ILessThanEqual, UnOp (LstLen, _)) - when Z.equal z Z.zero -> Expr.true_ - | BinOp (e1, (FLessThan as op), e2) | BinOp (e1, (ILessThan as op), e2) -> - let op_e : BinOp.t = - if op = FLessThan then FLessThanEqual else ILessThanEqual - in - if PFS.mem pfs (BinOp (e2, op_e, e1)) then Expr.false_ - else if PFS.mem pfs (BinOp (e2, op, e1)) then Expr.false_ - else fe (Expr.BinOp (e1, op, e2)) - | BinOp (e1, (FLessThanEqual as op), e2) - | BinOp (e1, (ILessThanEqual as op), e2) -> - let op_ne : BinOp.t = - if op = FLessThanEqual then FLessThan else ILessThan - in - if PFS.mem pfs (BinOp (e2, op, e1)) then BinOp (e1, Equal, e2) - else if PFS.mem pfs (BinOp (e1, op_ne, e2)) then Expr.true_ - else if PFS.mem pfs (BinOp (e2, op_ne, e1)) then Expr.false_ - else fe (Expr.BinOp (e1, op, e2)) - | BinOp (leb, SetMem, NOp ((SetUnion as op), lle)) - | BinOp (leb, SetMem, NOp ((SetInter as op), lle)) -> ( - let rleb = fe leb in - match lle with - | [] -> Expr.false_ - | le :: lle -> - let bop : BinOp.t = if op = SetUnion then Or else And in - let rle = fe le in - List.fold_left - (fun ac le -> - let rle = fe le in - Expr.BinOp (ac, bop, BinOp (rleb, SetMem, rle))) - (Expr.BinOp (rleb, SetMem, rle)) - lle) - | BinOp (leb, SetMem, BinOp (lel, SetDiff, ler)) -> - let rleb = fe leb in - let rlel = fe lel in - let rler = fe ler in - BinOp - ( BinOp (rleb, SetMem, rlel), - And, - UnOp (Not, BinOp (rleb, SetMem, rler)) ) - | BinOp (leb, SetMem, ESet les) -> - let rleb = fe leb in - let rles = List.map fe les in - let result = List.map (fun le -> Expr.BinOp (rleb, Equal, le)) rles in - Expr.disjunct result - | UnOp (IsInt, e) -> ( - match fe e with - | UnOp (UnOp.IntToNum, e) -> ( - let t, _ = Typing.type_lexpr gamma e in - match t with - | Some IntType -> Expr.true_ - | Some _ -> Expr.false_ - | None -> f @@ BinOp (UnOp (TypeOf, e), Equal, Lit (Type IntType)) - ) - | e' -> UnOp (IsInt, e')) - | BinOp (left, Impl, right) -> ( - let pfs_with_left = - let copy = PFS.copy pfs in - let () = PFS.extend copy left in - copy - in - let reduced_left = - reduce_formula_loop ~rpfs:true matching pfs_with_left gamma left - in - match (reduced_left, f right) with - | Lit (Bool true), _ -> right - | Lit (Bool false), _ | _, Lit (Bool true) -> Expr.true_ - | _, Lit (Bool false) -> f (UnOp (Not, left)) - | _ -> BinOp (left, Impl, right)) - | ForAll - ( [ (i, Some IntType) ], - BinOp - ( BinOp - ( BinOp (Lit (Int z), ILessThanEqual, LVar i'), - And, - BinOp (LVar i'', ILessThan, UnOp (LstLen, (EList ll as l))) - ), - Impl, - BinOp (BinOp (l', LstNth, LVar i'''), Equal, k) ) ) - when Z.(equal z zero) - && i = i' && i' = i'' && i'' = i''' && Expr.equal l l' -> - List.map (fun x -> Expr.Infix.(x == k)) ll |> Expr.conjunct - | ForAll (bt, a) -> ( - (* We create a new pfs and gamma where: - - All shadowed variables are substituted with a fresh variable - - The gamma has been updated with the types given in the binder *) - let new_gamma = Type_env.copy gamma in - let new_pfs = PFS.copy pfs in - let subst_bindings = List.map (fun (x, _) -> (x, LVar.alloc ())) bt in - let subst = - SVal.SESubst.init - (List.map - (fun (x, y) -> (Expr.LVar x, Expr.LVar y)) - subst_bindings) - in - let () = - List.iter - (fun (x, t) -> - let () = - match Type_env.get new_gamma x with - | Some t -> - let new_var = List.assoc x subst_bindings in - Type_env.update new_gamma new_var t - | None -> () - in - match t with - | Some t -> Type_env.update new_gamma x t - | None -> Type_env.remove new_gamma x) - bt - in - let () = PFS.substitution subst new_pfs in - (* We reduce using our new pfs and gamma *) - let ra = reduce_formula_loop ~rpfs matching new_pfs new_gamma a in - let vars = Expr.lvars ra in - let bt = List.filter (fun (b, _) -> Containers.SS.mem b vars) bt in - (* We remove all quantifiers that aren't used anymore *) - match bt with - | [] -> ra - | _ -> ForAll (bt, ra)) - | _ -> a - in - - f ~previous:a result - let reduce_formula ?(matching = false) - ?(rpfs = false) + ?(_rpfs = false) ?time:_ ?(pfs : PFS.t = PFS.init ()) ?(gamma = Type_env.init ()) (a : Expr.t) : Expr.t = - reduce_formula_loop ~top_level:true ~rpfs matching pfs gamma a + reduce_lexpr ~matching ~pfs ~gamma a +(* reduce_formula_loop ~top_level:true ~rpfs matching pfs gamma a *) let relate_llen (pfs : PFS.t) @@ -3176,8 +2871,7 @@ let reduce_assertion_loop | Pred (name, les) -> [ Pred (name, List.map fe les) ] (* Pure assertions *) | Pure (Lit (Bool true)) -> [] - | Pure f -> - [ Pure (reduce_formula_loop ~top_level:true matching pfs gamma f) ] + | Pure f -> [ Pure (reduce_lexpr ~matching ~pfs ~gamma f) ] (* Types *) | Types lvt -> ( try diff --git a/GillianCore/engine/FOLogic/Reduction.mli b/GillianCore/engine/FOLogic/Reduction.mli index 135d8352..29fb7213 100644 --- a/GillianCore/engine/FOLogic/Reduction.mli +++ b/GillianCore/engine/FOLogic/Reduction.mli @@ -36,7 +36,7 @@ val reduce_lexpr : The [matching] flag should not be used by Gillian instantiation developers. *) val reduce_formula : ?matching:bool -> - ?rpfs:bool -> + ?_rpfs:bool -> ?time:string -> ?pfs:PFS.t -> ?gamma:Type_env.t -> diff --git a/GillianCore/engine/FOLogic/Simplifications.ml b/GillianCore/engine/FOLogic/Simplifications.ml index 701b3882..ad59ccb6 100644 --- a/GillianCore/engine/FOLogic/Simplifications.ml +++ b/GillianCore/engine/FOLogic/Simplifications.ml @@ -975,7 +975,7 @@ let simplify_implication PFS.substitution subst rpfs; (* Additional *) - PFS.map_inplace (Reduction.reduce_formula ~rpfs:true ~gamma ~pfs:lpfs) rpfs; + PFS.map_inplace (Reduction.reduce_formula ~_rpfs:true ~gamma ~pfs:lpfs) rpfs; L.verbose (fun fmt -> fmt "REDUCED RPFS:\n%a" PFS.pp rpfs); sanitise_pfs_no_store ~matching gamma rpfs; From c027e8cb5820ce26ed7e28471479833be782679d Mon Sep 17 00:00:00 2001 From: N1ark Date: Sun, 29 Dec 2024 15:59:57 +0100 Subject: [PATCH 46/54] Fix reducing to true bc of PFS --- GillianCore/engine/FOLogic/Reduction.ml | 20 ++++++++++++++------ 1 file changed, 14 insertions(+), 6 deletions(-) diff --git a/GillianCore/engine/FOLogic/Reduction.ml b/GillianCore/engine/FOLogic/Reduction.ml index de287cfa..d545791d 100644 --- a/GillianCore/engine/FOLogic/Reduction.ml +++ b/GillianCore/engine/FOLogic/Reduction.ml @@ -2001,16 +2001,24 @@ and reduce_lexpr_loop | Equal -> ( let- () = if Expr.equal flel fler then Some Expr.true_ + (* This made sense when Expr!=Formula, because maybe we have the expr = while + knowing the formula = is true. + But now this always returns true, since the expr is always a formula. + Maybe add a flag, so it only happens if this isn't the "top level"? + + else if + PFS.exists + (fun e -> + Expr.equal e (BinOp (flel, Equal, fler)) + || Expr.equal e (BinOp (fler, Equal, flel))) + pfs + then Some Expr.true_ *) else if PFS.exists (fun e -> - Expr.equal e (BinOp (flel, Equal, fler)) - || Expr.equal e (BinOp (fler, Equal, flel))) + Expr.equal e (UnOp (Not, BinOp (flel, Equal, fler))) + || Expr.equal e (UnOp (Not, BinOp (fler, Equal, flel)))) pfs - then Some Expr.true_ - else if - PFS.mem pfs (UnOp (Not, BinOp (flel, Equal, fler))) - || PFS.mem pfs (UnOp (Not, BinOp (fler, Equal, flel))) then Some Expr.false_ else None in From 451857427e1ba0426dbeb4b69037444b227e2f26 Mon Sep 17 00:00:00 2001 From: N1ark Date: Sun, 29 Dec 2024 18:08:20 +0100 Subject: [PATCH 47/54] Fix reducing away all UnOps --- GillianCore/engine/FOLogic/Reduction.ml | 69 +++++++++++++------------ 1 file changed, 35 insertions(+), 34 deletions(-) diff --git a/GillianCore/engine/FOLogic/Reduction.ml b/GillianCore/engine/FOLogic/Reduction.ml index d545791d..5c405045 100644 --- a/GillianCore/engine/FOLogic/Reduction.ml +++ b/GillianCore/engine/FOLogic/Reduction.ml @@ -1429,12 +1429,10 @@ and reduce_lexpr_loop Option.fold ~some:(fun (_, tl) -> f tl) ~none:def ohdtl (* List operations: length *) | LstLen, EList le -> Expr.int (List.length le) + | LstLen, NOp (LstCat, []) -> Expr.zero_i | LstLen, NOp (LstCat, les) when lexpr_is_list gamma fle -> let les = List.map Expr.list_length les in - let le = - List.fold_left Expr.Infix.( + ) (List.hd les) (List.tl les) - in - f le + List.fold_left Expr.Infix.( + ) (List.hd les) (List.tl les) | LstLen, LstSub (_, _, len) when lexpr_is_list gamma fle -> len | LstLen, _ when lexpr_is_list gamma fle -> def (* List operations: reverse *) @@ -1564,7 +1562,14 @@ and reduce_lexpr_loop ------------------------- *) (* BinOps: Equalities (basics) *) | BinOp (e1, Equal, e2) when Expr.equal e1 e2 -> Expr.true_ - | BinOp (UnOp (op, e1), Equal, UnOp (op', e2)) when UnOp.equal op op' -> + (* BinOps: Equalities (injective unops) *) + | BinOp (UnOp (IUnaryMinus, e1), Equal, UnOp (IUnaryMinus, e2)) + | BinOp (UnOp (FUnaryMinus, e1), Equal, UnOp (FUnaryMinus, e2)) + | BinOp (UnOp (BitwiseNot, e1), Equal, UnOp (BitwiseNot, e2)) + | BinOp (UnOp (Not, e1), Equal, UnOp (Not, e2)) + | BinOp (UnOp (LstRev, e1), Equal, UnOp (LstRev, e2)) + | BinOp (UnOp (IntToNum, e1), Equal, UnOp (IntToNum, e2)) + | BinOp (UnOp (ToStringOp, e1), Equal, UnOp (ToStringOp, e2)) -> BinOp (e1, Equal, e2) (* BinOps: Equalities (locations) *) (* This line is the central mechanism to "matching": *) @@ -1584,27 +1589,29 @@ and reduce_lexpr_loop if List.length ll <> List.length lr then Expr.(false_) else if ll = [] then Expr.(true_) else List.map2 Expr.Infix.( == ) ll lr |> Expr.conjunct |> f + (* + This is super slow lol | BinOp (left_list, Equal, right_list) - when (*(match - ( Typing.type_lexpr gamma left_list, - Typing.type_lexpr gamma right_list ) - with - | (Some Type.ListType, _), (Some Type.ListType, _) -> true - | _ -> false)*) - lexpr_is_list gamma left_list - && lexpr_is_list gamma right_list - && - match - f - (Expr.Infix.( - ) - (Expr.list_length left_list) - (Expr.list_length right_list)) - with - | Expr.Lit (Int k) when not (Z.equal k Z.zero) -> true - | _ -> false -> - (* If we have two lists but can reduce the equality of their lengths to false, - then we know the lists cannot be equal*) - Expr.false_ + when (*(match + ( Typing.type_lexpr gamma left_list, + Typing.type_lexpr gamma right_list ) + with + | (Some Type.ListType, _), (Some Type.ListType, _) -> true + | _ -> false)*) + lexpr_is_list gamma left_list + && lexpr_is_list gamma right_list + && + match + f + (Expr.Infix.( - ) + (Expr.list_length left_list) + (Expr.list_length right_list)) + with + | Expr.Lit (Int k) when not (Z.equal k Z.zero) -> true + | _ -> false -> + (* If we have two lists but can reduce the equality of their lengths to false, + then we know the lists cannot be equal*) + Expr.false_ *) (* x = l1 ++ ... ++ ln when x = li and there is a non empty list => false *) | BinOp (NOp (LstCat, les), Equal, (LVar _ as x)) when List.mem x les @@ -1620,8 +1627,6 @@ and reduce_lexpr_loop | BinOp (e2, Equal, LstSub (e1, Lit (Int z), el)) when Z.equal z Z.zero && Expr.equal e1 e2 -> BinOp (UnOp (LstLen, e1), Equal, el) - | BinOp (UnOp (LstRev, ll), Equal, UnOp (LstRev, rl)) -> - BinOp (ll, Equal, rl) (* (l ++ ...)[0..n] = l <==> n = len(l) *) | BinOp (e2, Equal, LstSub (NOp (LstCat, e1 :: _), Lit (Int z), el)) when Z.equal z Z.zero && Expr.equal e1 e2 -> @@ -1806,8 +1811,6 @@ and reduce_lexpr_loop And, BinOp (sr, Equal, Lit (String "")) ) (* by injectivity *) - | BinOp (UnOp (ToStringOp, le1), Equal, UnOp (ToStringOp, le2)) -> - BinOp (le1, Equal, le2) | BinOp (UnOp (ToStringOp, le1), Equal, Lit (String s)) | BinOp (Lit (String s), Equal, UnOp (ToStringOp, le1)) -> ( match s with @@ -2343,13 +2346,11 @@ and simplify_int_arithmetic_lexpr | BinOp (l, IPlus, Lit (Int z)) when Z.equal z Z.zero -> l | BinOp (Lit (Int z), IPlus, l) when Z.equal z Z.zero -> l (* Binary minus to unary minus *) + (* Opale: how is this any better? *) | BinOp (l, IMinus, r) -> f (BinOp (l, IPlus, UnOp (IUnaryMinus, r))) (* Unary minus distributes over + *) - | UnOp (IUnaryMinus, e) -> ( - match e with - | BinOp (l, IPlus, r) -> - f (BinOp (UnOp (IUnaryMinus, l), IPlus, UnOp (IUnaryMinus, r))) - | _ -> le) + | UnOp (IUnaryMinus, BinOp (l, IPlus, r)) -> + f (BinOp (UnOp (IUnaryMinus, l), IPlus, UnOp (IUnaryMinus, r))) (* IPlus - we collect the positives and the negatives, see what we have and deal with them *) | BinOp (l, IPlus, r) -> let cl = Cint.of_expr l in From 9a4c36a371a4e1ba31c8cff3af7f110f8d3e3ae7 Mon Sep 17 00:00:00 2001 From: N1ark Date: Sun, 29 Dec 2024 22:06:17 +0100 Subject: [PATCH 48/54] Don't check PFS for Not --- GillianCore/engine/FOLogic/Reduction.ml | 18 +++++++++++------- 1 file changed, 11 insertions(+), 7 deletions(-) diff --git a/GillianCore/engine/FOLogic/Reduction.ml b/GillianCore/engine/FOLogic/Reduction.ml index 5c405045..b505e7b1 100644 --- a/GillianCore/engine/FOLogic/Reduction.ml +++ b/GillianCore/engine/FOLogic/Reduction.ml @@ -2016,13 +2016,17 @@ and reduce_lexpr_loop || Expr.equal e (BinOp (fler, Equal, flel))) pfs then Some Expr.true_ *) - else if - PFS.exists - (fun e -> - Expr.equal e (UnOp (Not, BinOp (flel, Equal, fler))) - || Expr.equal e (UnOp (Not, BinOp (fler, Equal, flel)))) - pfs - then Some Expr.false_ + (* + Same with this, eg. if we're reducing (! (a == b)), it then tries to reduce + (a == b), and of course its negation is in the PFS. + + else if + PFS.exists + (fun e -> + Expr.equal e (UnOp (Not, BinOp (flel, Equal, fler))) + || Expr.equal e (UnOp (Not, BinOp (fler, Equal, flel)))) + pfs + then Some Expr.false_*) else None in (* TODO: Here we don't use the 2nd param, is that ok? *) From f83afb91c63d94329f9b9c2d8103ccdfca847dbf Mon Sep 17 00:00:00 2001 From: N1ark Date: Sun, 29 Dec 2024 22:37:54 +0100 Subject: [PATCH 49/54] Disable other rule abt reducing to l-len --- GillianCore/engine/FOLogic/Reduction.ml | 27 +++++++++++++------------ 1 file changed, 14 insertions(+), 13 deletions(-) diff --git a/GillianCore/engine/FOLogic/Reduction.ml b/GillianCore/engine/FOLogic/Reduction.ml index b505e7b1..bdb0c4be 100644 --- a/GillianCore/engine/FOLogic/Reduction.ml +++ b/GillianCore/engine/FOLogic/Reduction.ml @@ -2016,17 +2016,17 @@ and reduce_lexpr_loop || Expr.equal e (BinOp (fler, Equal, flel))) pfs then Some Expr.true_ *) - (* - Same with this, eg. if we're reducing (! (a == b)), it then tries to reduce - (a == b), and of course its negation is in the PFS. - - else if - PFS.exists - (fun e -> - Expr.equal e (UnOp (Not, BinOp (flel, Equal, fler))) - || Expr.equal e (UnOp (Not, BinOp (fler, Equal, flel)))) - pfs - then Some Expr.false_*) + + (* Same with this, eg. if we're reducing (! (a == b)), it then tries to reduce + (a == b), and of course its negation is in the PFS. + + else if + PFS.exists + (fun e -> + Expr.equal e (UnOp (Not, BinOp (flel, Equal, fler))) + || Expr.equal e (UnOp (Not, BinOp (fler, Equal, flel)))) + pfs + then Some Expr.false_*) else None in (* TODO: Here we don't use the 2nd param, is that ok? *) @@ -2039,8 +2039,9 @@ and reduce_lexpr_loop in match (flel, fler) with (* "RPFS" only? whatever that meant it's here now. *) - | NOp (LstCat, _), LVar y when (* rpfs && *) prefix_catch pfs flel y - -> BinOp (UnOp (LstLen, flel), Equal, UnOp (LstLen, fler)) + (* How does this make any sense?? l1 = l2 <=/=> len(l1) = len(l2) + | NOp (LstCat, _), LVar y when (* rpfs && *) prefix_catch pfs flel y + -> BinOp (UnOp (LstLen, flel), Equal, UnOp (LstLen, fler)) *) (* Lists *) | EList [], x | x, EList [] | Lit (LList []), x | x, Lit (LList []) -> ( From 641c12b08a9cff05641710c0e0b5a8d7e017f883 Mon Sep 17 00:00:00 2001 From: N1ark Date: Sun, 29 Dec 2024 23:58:56 +0100 Subject: [PATCH 50/54] Small optim `Type_env.get_unsafe` --- GillianCore/engine/FOLogic/type_env.ml | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/GillianCore/engine/FOLogic/type_env.ml b/GillianCore/engine/FOLogic/type_env.ml index 80a69b16..2cb62659 100644 --- a/GillianCore/engine/FOLogic/type_env.ml +++ b/GillianCore/engine/FOLogic/type_env.ml @@ -30,9 +30,9 @@ let empty (x : t) : bool = Hashtbl.length x == 0 (* Type of a variable *) let get_unsafe (x : t) (var : string) : Type.t = - match Hashtbl.mem x var with - | true -> Hashtbl.find x var - | false -> + match Hashtbl.find_opt x var with + | Some t -> t + | None -> raise (Failure ("Type_env.get_unsafe: variable " ^ var ^ " not found.")) (* Get all matchable elements *) From 6f812b1788ada4320aca3eb0ce7e800034d59980 Mon Sep 17 00:00:00 2001 From: N1ark Date: Mon, 30 Dec 2024 00:26:08 +0100 Subject: [PATCH 51/54] Fix reducing before comparing with `Nono` --- GillianCore/engine/FOLogic/Reduction.ml | 12 +++++++++++- 1 file changed, 11 insertions(+), 1 deletion(-) diff --git a/GillianCore/engine/FOLogic/Reduction.ml b/GillianCore/engine/FOLogic/Reduction.ml index bdb0c4be..e703a476 100644 --- a/GillianCore/engine/FOLogic/Reduction.ml +++ b/GillianCore/engine/FOLogic/Reduction.ml @@ -1826,12 +1826,22 @@ and reduce_lexpr_loop | EList _ | ESet _ -> Expr.false_ | _ -> le) | BinOp (Lit l1, Equal, Lit l2) -> Expr.bool (l1 = l2) + | BinOp (Lit Nono, Equal, PVar _) | BinOp (PVar _, Equal, Lit Nono) -> le (* JOSE: Why are we considering the case of a logical variable being bound to None? *) | BinOp (Lit Nono, Equal, LVar x) | BinOp (LVar x, Equal, Lit Nono) -> ( match Type_env.get gamma x with | None | Some NoneType -> le | _ -> Expr.false_) - | BinOp (Lit Nono, Equal, _) | BinOp (_, Equal, Lit Nono) -> Expr.false_ + | BinOp (Lit Nono, Equal, e) | BinOp (e, Equal, Lit Nono) -> ( + let fe = f e in + match fe with + | Lit Nono -> Expr.true_ + | Lit _ -> Expr.false_ + | LVar x when Type_env.get gamma x = Some NoneType -> + BinOp (Lit Nono, Equal, fe) + | PVar _ -> BinOp (Lit Nono, Equal, fe) + | LVar _ -> Expr.false_ + | _ -> Expr.false_) (* BinOps: Equalities (typing) *) (* Can this be generalised? add an fn to typing, that maps BinOp -> ret type *) | BinOp (UnOp (TypeOf, BinOp (_, StrCat, _)), Equal, Lit (Type t)) From 3f536b30106af31b41816b4dda3b10f25b0987ba Mon Sep 17 00:00:00 2001 From: N1ark Date: Mon, 30 Dec 2024 00:50:34 +0100 Subject: [PATCH 52/54] Remove `reduce_formula` !!!! --- GillianCore/engine/Abstraction/Matcher.ml | 2 +- GillianCore/engine/FOLogic/FOSolver.ml | 13 +++++-------- GillianCore/engine/FOLogic/Reduction.ml | 14 +++----------- GillianCore/engine/FOLogic/Reduction.mli | 12 ------------ GillianCore/engine/FOLogic/Simplifications.ml | 8 ++++---- GillianCore/engine/general_semantics/stateErr.ml | 4 ++-- GillianCore/engine/symbolic_semantics/SState.ml | 8 +------- GillianCore/monadic/FOSolver.ml | 6 +----- GillianCore/monadic/delayed.ml | 1 - GillianCore/monadic/delayed.mli | 1 - GillianCore/monadic/pc.ml | 2 +- 11 files changed, 18 insertions(+), 53 deletions(-) diff --git a/GillianCore/engine/Abstraction/Matcher.ml b/GillianCore/engine/Abstraction/Matcher.ml index 42995e28..8af919b1 100644 --- a/GillianCore/engine/Abstraction/Matcher.ml +++ b/GillianCore/engine/Abstraction/Matcher.ml @@ -1346,7 +1346,7 @@ module Make (State : SState.S) : List.fold_left Expr.Infix.( && ) Expr.true_ discharges in let discharges_pf = - Reduction.reduce_formula ~matching:true discharges_pf + Reduction.reduce_lexpr ~matching:true discharges_pf in let to_asrt = Expr.Infix.( && ) pf discharges_pf in match cons_pure state to_asrt with diff --git a/GillianCore/engine/FOLogic/FOSolver.ml b/GillianCore/engine/FOLogic/FOSolver.ml index d5d16868..86b74963 100644 --- a/GillianCore/engine/FOLogic/FOSolver.ml +++ b/GillianCore/engine/FOLogic/FOSolver.ml @@ -11,7 +11,7 @@ let get_axioms (fs : Expr.Set.t) (_ : Type_env.t) : Expr.Set.t = match pf with | BinOp (NOp (LstCat, x), Equal, NOp (LstCat, y)) -> Expr.Set.add - (Reduction.reduce_formula + (Reduction.reduce_lexpr (BinOp ( UnOp (LstLen, NOp (LstCat, x)), Equal, @@ -95,7 +95,7 @@ let check_satisfiability result let sat ~matching ~pfs ~gamma formula : bool = - let formula' = Reduction.reduce_formula ~matching ~pfs ~gamma formula in + let formula' = Reduction.reduce_lexpr ~matching ~pfs ~gamma formula in match formula' with | Lit (Bool b) -> Logging.verbose (fun fmt -> @@ -219,10 +219,7 @@ let check_entailment let is_equal ~pfs ~gamma e1 e2 = (* let t = Sys.time () in *) - let feq = - Reduction.reduce_formula ?gamma:(Some gamma) ?pfs:(Some pfs) - (BinOp (e1, Equal, e2)) - in + let feq = Reduction.reduce_lexpr ~gamma ~pfs (BinOp (e1, Equal, e2)) in let result = match feq with | Lit (Bool b) -> b @@ -240,7 +237,7 @@ let is_equal ~pfs ~gamma e1 e2 = let is_different ~pfs ~gamma e1 e2 = (* let t = Sys.time () in *) let feq = - Reduction.reduce_formula ~gamma ~pfs (UnOp (Not, BinOp (e1, Equal, e2))) + Reduction.reduce_lexpr ~gamma ~pfs (UnOp (Not, BinOp (e1, Equal, e2))) in let result = match feq with @@ -257,7 +254,7 @@ let is_different ~pfs ~gamma e1 e2 = let num_is_less_or_equal ~pfs ~gamma e1 e2 = let feq = - Reduction.reduce_formula ~gamma ~pfs (Expr.BinOp (e1, FLessThanEqual, e2)) + Reduction.reduce_lexpr ~gamma ~pfs (Expr.BinOp (e1, FLessThanEqual, e2)) in let result = match feq with diff --git a/GillianCore/engine/FOLogic/Reduction.ml b/GillianCore/engine/FOLogic/Reduction.ml index e703a476..3042b5ef 100644 --- a/GillianCore/engine/FOLogic/Reduction.ml +++ b/GillianCore/engine/FOLogic/Reduction.ml @@ -2328,6 +2328,8 @@ and reduce_lexpr (* let t = Sys.time () in *) let result = reduce_lexpr_loop ~matching ~reduce_lvars pfs gamma le in (* Utils.Statistics.update_statistics "Reduce Expression" (Sys.time () -. t); *) + Logging.normal (fun f -> + f "reduce_lexpr: @[%a -> %a@]" Expr.pp le Expr.pp result); result and simplify_num_arithmetic_lexpr @@ -2707,16 +2709,6 @@ let resolve_expr_to_location (pfs : PFS.t) (gamma : Type_env.t) (e : Expr.t) : in resolve_expr_to_location_aux max_fuel Expr.Set.empty [ e ] -let reduce_formula - ?(matching = false) - ?(_rpfs = false) - ?time:_ - ?(pfs : PFS.t = PFS.init ()) - ?(gamma = Type_env.init ()) - (a : Expr.t) : Expr.t = - reduce_lexpr ~matching ~pfs ~gamma a -(* reduce_formula_loop ~top_level:true ~rpfs matching pfs gamma a *) - let relate_llen (pfs : PFS.t) (gamma : Type_env.t) @@ -2962,4 +2954,4 @@ let reduce_assertion loop a let is_tautology ?pfs ?gamma formula = - reduce_formula ?pfs ?gamma formula = Lit (Bool true) + reduce_lexpr ?pfs ?gamma formula = Lit (Bool true) diff --git a/GillianCore/engine/FOLogic/Reduction.mli b/GillianCore/engine/FOLogic/Reduction.mli index 29fb7213..dfa70eab 100644 --- a/GillianCore/engine/FOLogic/Reduction.mli +++ b/GillianCore/engine/FOLogic/Reduction.mli @@ -31,18 +31,6 @@ val reduce_lexpr : Gil_syntax.Expr.t -> Gil_syntax.Expr.t -(** [reduce_formula ?matching ?pfs ?gamma pf] reduces the formula [pf] - given (optional) pure formulae [pfs] and typing environment [gamma]. - The [matching] flag should not be used by Gillian instantiation developers. *) -val reduce_formula : - ?matching:bool -> - ?_rpfs:bool -> - ?time:string -> - ?pfs:PFS.t -> - ?gamma:Type_env.t -> - Gil_syntax.Expr.t -> - Gil_syntax.Expr.t - (** [reduce_assertion ?matching ?pfs ?gamma a] reduces the assertion [a] given (optional) pure formulae [pfs] and typing environment [gamma]. The [matching] flag should not be used by Gillian instantiation developers. *) diff --git a/GillianCore/engine/FOLogic/Simplifications.ml b/GillianCore/engine/FOLogic/Simplifications.ml index ad59ccb6..a6a856ec 100644 --- a/GillianCore/engine/FOLogic/Simplifications.ml +++ b/GillianCore/engine/FOLogic/Simplifications.ml @@ -30,7 +30,7 @@ let simplification_cache : (simpl_key_type, simpl_val_type) Hashtbl.t = (*************************************) let reduce_pfs_in_place ?(matching = false) _ gamma (pfs : PFS.t) = - PFS.map_inplace (Reduction.reduce_formula ~matching ~gamma ~pfs) pfs + PFS.map_inplace (Reduction.reduce_lexpr ~matching ~gamma ~pfs) pfs let sanitise_pfs ?(matching = false) store gamma pfs = let old_pfs = ref (PFS.init ()) in @@ -390,7 +390,7 @@ let simplify_pfs_and_gamma (* Reduce current assertion *) let rec_call = filter_mapper_formula pfs in let extend_with = PFS.extend pfs in - let whole = Reduction.reduce_formula ~matching ~gamma ~pfs pf in + let whole = Reduction.reduce_lexpr ~matching ~gamma ~pfs pf in match whole with (* These we must not encounter here *) | ForAll (bt, _) -> @@ -960,7 +960,7 @@ let simplify_implication match pf with | BinOp (NOp (LstCat, lex), Equal, NOp (LstCat, ley)) -> let flen_eq = - Reduction.reduce_formula ~gamma ~pfs:lpfs + Reduction.reduce_lexpr ~gamma ~pfs:lpfs (BinOp ( UnOp (LstLen, NOp (LstCat, lex)), Equal, @@ -975,7 +975,7 @@ let simplify_implication PFS.substitution subst rpfs; (* Additional *) - PFS.map_inplace (Reduction.reduce_formula ~_rpfs:true ~gamma ~pfs:lpfs) rpfs; + PFS.map_inplace (Reduction.reduce_lexpr ~gamma ~pfs:lpfs) rpfs; L.verbose (fun fmt -> fmt "REDUCED RPFS:\n%a" PFS.pp rpfs); sanitise_pfs_no_store ~matching gamma rpfs; diff --git a/GillianCore/engine/general_semantics/stateErr.ml b/GillianCore/engine/general_semantics/stateErr.ml index 7bdca364..3e799dd4 100644 --- a/GillianCore/engine/general_semantics/stateErr.ml +++ b/GillianCore/engine/general_semantics/stateErr.ml @@ -50,9 +50,9 @@ let pp_err let can_fix (can_fix_mem : 'a -> bool) (err : ('a, 'b) t) : bool = match err with | EMem mem_err -> can_fix_mem mem_err - | EPure pf -> Reduction.reduce_formula pf <> Expr.false_ + | EPure pf -> Reduction.reduce_lexpr pf <> Expr.false_ | EAsrt (_, pf, _) -> - let result = Reduction.reduce_formula pf <> Expr.true_ in + let result = Reduction.reduce_lexpr pf <> Expr.true_ in Logging.verbose (fun fmt -> fmt "Can fix: %a: %b" Expr.pp pf result); result | _ -> false diff --git a/GillianCore/engine/symbolic_semantics/SState.ml b/GillianCore/engine/symbolic_semantics/SState.ml index e4852140..79784f31 100644 --- a/GillianCore/engine/symbolic_semantics/SState.ml +++ b/GillianCore/engine/symbolic_semantics/SState.ml @@ -300,13 +300,7 @@ module Make (SMemory : SMemory.S) : (ps : Expr.t list) : t option = let { pfs; gamma; _ } = state in try - let ps = - List.map - (Reduction.reduce_formula - ~time:("SState: assume_a: " ^ time) - ~pfs ~gamma) - ps - in + let ps = List.map (Reduction.reduce_lexpr ~pfs ~gamma) ps in let result = if production diff --git a/GillianCore/monadic/FOSolver.ml b/GillianCore/monadic/FOSolver.ml index 60727a59..97a8e621 100644 --- a/GillianCore/monadic/FOSolver.ml +++ b/GillianCore/monadic/FOSolver.ml @@ -33,7 +33,7 @@ let check_entailment ~(pc : Pc.t) formula = let pfs, gamma = (build_full_pfs pc, build_full_gamma pc) in try let f = - Engine.Reduction.reduce_formula ~matching:pc.matching ~gamma ~pfs formula + Engine.Reduction.reduce_lexpr ~matching:pc.matching ~gamma ~pfs formula in match f with | Lit (Bool b) -> b @@ -63,10 +63,6 @@ let reduce_expr ~pc expr = Reduction.reduce_lexpr ~matching:pc.Pc.matching ~pfs:(build_full_pfs pc) ~gamma:(build_full_gamma pc) expr -let reduce_formula ~pc formula = - Reduction.reduce_formula ~matching:pc.Pc.matching ~pfs:(build_full_pfs pc) - ~gamma:(build_full_gamma pc) formula - let resolve_type ~(pc : Pc.t) expr = (* TODO: I don't know what that how parameter means. I'm copying what Reduction does. diff --git a/GillianCore/monadic/delayed.ml b/GillianCore/monadic/delayed.ml index d91971f3..deae9e9a 100644 --- a/GillianCore/monadic/delayed.ml +++ b/GillianCore/monadic/delayed.ml @@ -93,7 +93,6 @@ let delayed_eval2 f x y ~curr_pc = [ Branch.make ~pc:curr_pc ~value:(f ~pc:curr_pc x y) ] let reduce = delayed_eval FOSolver.reduce_expr -let reduce_formula = delayed_eval FOSolver.reduce_formula let resolve_loc = delayed_eval FOSolver.resolve_loc_name let entails = diff --git a/GillianCore/monadic/delayed.mli b/GillianCore/monadic/delayed.mli index 107dcb92..dc0413bf 100644 --- a/GillianCore/monadic/delayed.mli +++ b/GillianCore/monadic/delayed.mli @@ -9,7 +9,6 @@ val return : val resolve_loc : Expr.t -> string option t val reduce : Expr.t -> Expr.t t -val reduce_formula : Expr.t -> Expr.t t val entails : Expr.t list -> Expr.t -> bool t val check_sat : Expr.t -> bool t val bind : 'a t -> ('a -> 'b t) -> 'b t diff --git a/GillianCore/monadic/pc.ml b/GillianCore/monadic/pc.ml index c6ea4bef..d4172947 100644 --- a/GillianCore/monadic/pc.ml +++ b/GillianCore/monadic/pc.ml @@ -63,7 +63,7 @@ let extend pc fs = List.filter_map (fun f -> match - Engine.Reduction.reduce_formula ~matching:pc.matching ~pfs ~gamma f + Engine.Reduction.reduce_lexpr ~matching:pc.matching ~pfs ~gamma f with | Expr.Lit (Bool true) -> None | f -> Some f) From 3834539778818375520f178ced16959485939d83 Mon Sep 17 00:00:00 2001 From: N1ark Date: Mon, 30 Dec 2024 17:24:23 +0100 Subject: [PATCH 53/54] Remove comments + unneeded reductions --- GillianCore/GIL_Syntax/Expr.ml | 3 +- GillianCore/engine/FOLogic/Reduction.ml | 263 ++++++++---------------- 2 files changed, 86 insertions(+), 180 deletions(-) diff --git a/GillianCore/GIL_Syntax/Expr.ml b/GillianCore/GIL_Syntax/Expr.ml index 656ba27f..063f1422 100644 --- a/GillianCore/GIL_Syntax/Expr.ml +++ b/GillianCore/GIL_Syntax/Expr.ml @@ -13,8 +13,9 @@ type t = TypeDef__.expr = | EList of t list (** Lists of expressions *) | ESet of t list (** Sets of expressions *) | Exists of (string * Type.t option) list * t - (** Existential quantification. This is now a circus because the separation between Formula and Expr doesn't make sense anymore. *) + (** Existential quantification. *) | ForAll of (string * Type.t option) list * t + (** Universal quantification. *) [@@deriving eq, ord] let to_yojson = TypeDef__.expr_to_yojson diff --git a/GillianCore/engine/FOLogic/Reduction.ml b/GillianCore/engine/FOLogic/Reduction.ml index 3042b5ef..19e2aa58 100644 --- a/GillianCore/engine/FOLogic/Reduction.ml +++ b/GillianCore/engine/FOLogic/Reduction.ml @@ -38,9 +38,8 @@ let normalise_cat (f : Expr.t -> Expr.t) (les : Expr.t list) : Expr.t = (* Filter out empty lists *) let nles = List.filter - (fun (x : Expr.t) -> - match x with - | Lit (LList []) | EList [] -> false + (function + | Expr.Lit (LList []) | EList [] -> false | _ -> true) nles in @@ -222,8 +221,7 @@ let find_equalities (pfs : PFS.t) (le : Expr.t) : Expr.t list = let typable (gamma : Type_env.t) (le : Expr.t) (target_type : Type.t) : bool = let t, success = Typing.type_lexpr gamma le in - if success then - Option.fold ~some:(fun t -> Type.equal t target_type) ~none:true t + if success then Option.fold ~some:(Type.equal target_type) ~none:true t else let msg : string = Fmt.str "TYPE ERROR: %a not typable in typing environment %a" Expr.pp le @@ -390,12 +388,12 @@ let rec get_length_of_string (str : Expr.t) : int option = | Lit (String s) -> Some (String.length s) | BinOp (sl, StrCat, sr) -> Option.value ~default:None - (Option.map (fun ll -> Option.map (fun lr -> ll + lr) (f sr)) (f sl)) + (Option.map (fun ll -> Option.map (( + ) ll) (f sr)) (f sl)) | _ -> raise (Failure - (Printf.sprintf "get_length_of_string: string equals %s, impossible" - ((Fmt.to_to_string Expr.pp) str))) + (Fmt.str "get_length_of_string: string equals %a, impossible" Expr.pp + str)) (* Finding the nth element of a list *) let rec get_nth_of_string (str : Expr.t) (idx : int) : Expr.t option = @@ -405,11 +403,10 @@ let rec get_nth_of_string (str : Expr.t) (idx : int) : Expr.t option = (* If we can compute the length of the list, then the index needs to be compatible *) let olen = get_length_of_string str in - let _ = + let () = match olen with - | None -> () - | Some len -> - if len <= idx then raise (ReductionException (Lit Nono, err_msg)) + | Some len when len <= idx -> raise (ReductionException (Lit Nono, err_msg)) + | _ -> () in let result : Expr.t option = @@ -422,19 +419,14 @@ let rec get_nth_of_string (str : Expr.t) (idx : int) : Expr.t option = assert (idx < String.length s); Some (Lit (String (String.sub s idx 1))) | BinOp (ls, StrCat, rs) -> - Option.value ~default:None - (Option.map - (fun llen -> - let lst, idx = - if idx < llen then (ls, idx) else (rs, idx - llen) - in - f lst idx) - (get_length_of_string ls)) + Option.bind (get_length_of_string ls) (fun llen -> + let lst, idx = if idx < llen then (ls, idx) else (rs, idx - llen) in + f lst idx) | _ -> raise (Failure - (Printf.sprintf "get_nth_of_string: string equals %s, impossible" - ((Fmt.to_to_string Expr.pp) str))) + (Fmt.str "get_nth_of_string: string equals %a, impossible" Expr.pp + str)) in result @@ -499,13 +491,10 @@ let rec contained_in_union (pfs : Expr.t list) (le1 : Expr.t) (le2 : Expr.t) = m "Contained in union: %s %s" ((Fmt.to_to_string Expr.pp) le1) ((Fmt.to_to_string Expr.pp) le2))); - match le2 with - | LVar _ -> ( - match pfs with - | [] -> false - | BinOp (le, Equal, NOp (SetUnion, les)) :: rest when le = le2 -> - if List.mem le1 les then true else contained_in_union rest le1 le2 - | _ :: rest -> contained_in_union rest le1 le2) + match (le2, pfs) with + | LVar _, BinOp (le, Equal, NOp (SetUnion, les)) :: _ + when le = le2 && List.mem le1 les -> true + | LVar _, _ :: rest -> contained_in_union rest le1 le2 | _ -> false let all_different pfs les = @@ -602,10 +591,7 @@ let prefix_catch pfs (x : Expr.t) (y : string) = PFS.exists (function | BinOp (NOp (LstCat, lx), Equal, NOp (LstCat, LVar y' :: _)) - when y = y' -> ( - match List_utils.list_sub lx 0 (List.length x) with - | Some x' -> x' = x - | _ -> false) + when y = y' -> List_utils.list_sub lx 0 (List.length x) = Some x | _ -> false) pfs | LVar x -> @@ -1084,10 +1070,10 @@ and reduce_lexpr_loop when Int.equal (List.compare_length_with les (Z.to_int n)) 0 -> Some (NOp (LstCat, rest)) | _ -> None) - |> Option.get |> f + |> Option.get | LstSub (e1, Lit (Int z), e3) when Z.equal z Z.zero - && List.mem (Cint.of_expr e3) (find_list_length_eqs pfs e1) -> f e1 + && List.mem (Cint.of_expr e3) (find_list_length_eqs pfs e1) -> e1 | LstSub (le1, le2, le3) -> ( let fle1 = f le1 in let fle2 = substitute_for_list_length pfs (f le2) in @@ -1168,7 +1154,7 @@ and reduce_lexpr_loop in Logging.tmi (fun m -> m "Case 5:\nRes: %a\nOriginal: %a" Expr.pp res Expr.pp le); - f res + res | le, Lit (Int z), Lit (Int n) when Z.equal z Z.zero && (match le with @@ -1228,13 +1214,12 @@ and reduce_lexpr_loop in (* L.tmi (fun fmt -> fmt "EQs: %a" Fmt.(brackets (list ~sep:comma Expr.pp)) eqs); *) - f - (Expr.list_sub ~lst:(Option.get first) ~start:(Expr.int 0) - ~size:(Expr.int_z n)) + Expr.list_sub ~lst:(Option.get first) ~start:(Expr.int 0) + ~size:(Expr.int_z n) | fle1, UnOp (LstLen, lx), fle3 when fst (list_prefix pfs lx fle1) -> L.tmi (fun fmt -> fmt "Case 7"); let _, suffix = list_prefix pfs lx fle1 in - f (LstSub (suffix, Expr.zero_i, fle3)) + LstSub (suffix, Expr.zero_i, fle3) | fle1, Lit (Int z), UnOp (LstLen, LVar lx) when Z.equal z Z.zero && List.exists @@ -1306,10 +1291,7 @@ and reduce_lexpr_loop let new_lstsub = Expr.LstSub (NOp (LstCat, ler), diff, fle3) in L.verbose (fun fmt -> fmt "Recursively calling with: %a" Expr.pp new_lstsub); - let result = f new_lstsub in - L.verbose (fun fmt -> - fmt "LSUB: Start after first result: %a" Expr.pp result); - result + new_lstsub | NOp (LstCat, EList lel :: ler), Lit (Int n), fle3 when Z.gt n Z.zero -> L.tmi (fun fmt -> fmt "Case 13"); @@ -1325,7 +1307,7 @@ and reduce_lexpr_loop ) in let result = - f (LstSub (NOp (LstCat, rest_of_lel :: ler), Expr.zero_i, fle3)) + Expr.LstSub (NOp (LstCat, rest_of_lel :: ler), Expr.zero_i, fle3) in L.verbose (fun fmt -> fmt "LSUB: Start inside first result: %a" Expr.pp result); @@ -1342,16 +1324,15 @@ and reduce_lexpr_loop fmt "LSUB: Contains first: %a" Expr.pp (LstSub (fle1, fle2, fle3))); let result = - f - (NOp - ( LstCat, - [ - lel; - LstSub - ( NOp (LstCat, ler), - Expr.zero_i, - BinOp (fle3, IMinus, UnOp (LstLen, lel)) ); - ] )) + Expr.NOp + ( LstCat, + [ + lel; + LstSub + ( NOp (LstCat, ler), + Expr.zero_i, + BinOp (fle3, IMinus, UnOp (LstLen, lel)) ); + ] ) in L.verbose (fun fmt -> fmt "LSUB: Contains first result: %a" Expr.pp result); @@ -1362,9 +1343,14 @@ and reduce_lexpr_loop (* ------------------------- UnOp ------------------------- *) - | UnOp (NumToInt, UnOp (IntToNum, le)) -> f le + (* Cancelling *) + | UnOp (NumToInt, UnOp (IntToNum, e)) + | UnOp (FUnaryMinus, UnOp (FUnaryMinus, e)) + | UnOp (IUnaryMinus, UnOp (IUnaryMinus, e)) + | UnOp (LstLen, BinOp (_, LstRepeat, e)) + | UnOp (LstLen, LstSub (_, _, e)) -> e | UnOp (IntToNum, UnOp (NumToInt, le)) when PFS.mem pfs (UnOp (IsInt, le)) - -> f le + -> le (* Number-to-string-to-number-to-string-to... *) | UnOp (ToNumberOp, UnOp (ToStringOp, le)) -> ( let fle = f le in @@ -1375,20 +1361,12 @@ and reduce_lexpr_loop match (how, tfle) with | true, Some NumberType -> fle | _, _ -> UnOp (ToNumberOp, UnOp (ToStringOp, fle)))) - | UnOp (LstRev, UnOp (LstRev, le)) -> f le + | UnOp (LstRev, UnOp (LstRev, le)) -> le (* Less than and lessthaneq *) - | UnOp (Not, BinOp (le1, FLessThan, le2)) -> - f (BinOp (f le2, FLessThanEqual, f le1)) - | UnOp (Not, BinOp (le1, FLessThanEqual, le2)) -> - f (BinOp (f le2, FLessThan, f le1)) - | UnOp (Not, BinOp (le1, ILessThan, le2)) -> - f (BinOp (f le2, ILessThanEqual, f le1)) - | UnOp (Not, BinOp (le1, ILessThanEqual, le2)) -> - f (BinOp (f le2, ILessThan, f le1)) - | UnOp (FUnaryMinus, UnOp (FUnaryMinus, e)) -> f e - | UnOp (IUnaryMinus, UnOp (IUnaryMinus, e)) -> f e - | UnOp (LstLen, BinOp (_, LstRepeat, e)) -> f e - | UnOp (LstLen, LstSub (_, _, e)) -> f e + | UnOp (Not, BinOp (le1, FLessThan, le2)) -> BinOp (le2, FLessThanEqual, le1) + | UnOp (Not, BinOp (le1, FLessThanEqual, le2)) -> BinOp (le2, FLessThan, le1) + | UnOp (Not, BinOp (le1, ILessThan, le2)) -> BinOp (le2, ILessThanEqual, le1) + | UnOp (Not, BinOp (le1, ILessThanEqual, le2)) -> BinOp (le2, ILessThan, le1) | UnOp (op, le) -> ( let fle = f le in let def = Expr.UnOp (op, fle) in @@ -1401,11 +1379,9 @@ and reduce_lexpr_loop raise (ReductionException (def, err_msg)) | e -> raise e) (* Negation *) - | Not, UnOp (Not, ex) -> f ex - | Not, BinOp (ex, And, ey) -> - f (BinOp (UnOp (Not, ex), Or, UnOp (Not, ey))) - | Not, BinOp (ex, Or, ey) -> - f (BinOp (UnOp (Not, ex), And, UnOp (Not, ey))) + | Not, UnOp (Not, ex) -> ex + | Not, BinOp (ex, And, ey) -> BinOp (UnOp (Not, ex), Or, UnOp (Not, ey)) + | Not, BinOp (ex, Or, ey) -> BinOp (UnOp (Not, ex), And, UnOp (Not, ey)) | Not, _ -> def (* The TypeOf operator *) | TypeOf, _ -> ( @@ -1467,8 +1443,7 @@ and reduce_lexpr_loop match Typing.type_lexpr gamma e with | Some IntType, _ -> Expr.true_ | Some _, _ -> Expr.false_ - | None, _ -> f (BinOp (UnOp (TypeOf, e), Equal, Lit (Type IntType))) - ) + | None, _ -> BinOp (UnOp (TypeOf, e), Equal, Lit (Type IntType))) | _, _ -> def) (* ------------------------- NOp @@ -1477,10 +1452,9 @@ and reduce_lexpr_loop (* l[0..n] ++ l[n..n+m] ++ rest <=> l[0..n+m] ++ rest *) | NOp (LstCat, LstSub (x1, Lit (Int z), z1) :: LstSub (x2, y2, z3) :: rest) when Z.equal z Z.zero && Expr.equal x1 x2 && Expr.equal z1 y2 -> - f - (NOp (LstCat, LstSub (x1, Expr.zero_i, Expr.Infix.( + ) z1 z3) :: rest)) + NOp (LstCat, LstSub (x1, Expr.zero_i, Expr.Infix.( + ) z1 z3) :: rest) | NOp (LstCat, fst :: rest) when PFS.mem pfs (BinOp (fst, Equal, EList [])) - -> f (NOp (LstCat, rest)) + -> NOp (LstCat, rest) | NOp (LstCat, [ x; LstSub (LVar y, UnOp (LstLen, x'), len) ]) when x = x' && Cint.canonicalise len @@ -1525,7 +1499,7 @@ and reduce_lexpr_loop | _ -> NOp (SetUnion, fles)) (* Set intersection *) | NOp (SetInter, [ BinOp (le1, SetDiff, le2); ESet le3 ]) -> - f (NOp (SetInter, [ le2; BinOp (ESet le3, SetDiff, le1) ])) + NOp (SetInter, [ le2; BinOp (ESet le3, SetDiff, le1) ]) | NOp (SetInter, les) -> ( let fles = List.map f les in (* Flatten intersections *) @@ -1584,34 +1558,11 @@ and reduce_lexpr_loop else if ll = [] then Expr.true_ else List.map2 (fun x y -> Expr.Infix.( == ) x (Lit y)) le ll - |> Expr.conjunct |> f + |> Expr.conjunct | BinOp (EList ll, Equal, EList lr) -> if List.length ll <> List.length lr then Expr.(false_) else if ll = [] then Expr.(true_) - else List.map2 Expr.Infix.( == ) ll lr |> Expr.conjunct |> f - (* - This is super slow lol - | BinOp (left_list, Equal, right_list) - when (*(match - ( Typing.type_lexpr gamma left_list, - Typing.type_lexpr gamma right_list ) - with - | (Some Type.ListType, _), (Some Type.ListType, _) -> true - | _ -> false)*) - lexpr_is_list gamma left_list - && lexpr_is_list gamma right_list - && - match - f - (Expr.Infix.( - ) - (Expr.list_length left_list) - (Expr.list_length right_list)) - with - | Expr.Lit (Int k) when not (Z.equal k Z.zero) -> true - | _ -> false -> - (* If we have two lists but can reduce the equality of their lengths to false, - then we know the lists cannot be equal*) - Expr.false_ *) + else List.map2 Expr.Infix.( == ) ll lr |> Expr.conjunct (* x = l1 ++ ... ++ ln when x = li and there is a non empty list => false *) | BinOp (NOp (LstCat, les), Equal, (LVar _ as x)) when List.mem x les @@ -1771,8 +1722,8 @@ and reduce_lexpr_loop BinOp (e, Equal, Expr.zero_i) | BinOp (BinOp (a, FTimes, b), FMod, c) when Expr.equal a c || Expr.equal b c -> Expr.num 0. - | BinOp (x, FTimes, BinOp (y, FDiv, z)) when x = z -> f y - | BinOp (BinOp (x, FDiv, y), FTimes, z) when y = z -> f x + | BinOp (x, FTimes, BinOp (y, FDiv, z)) when x = z -> y + | BinOp (BinOp (x, FDiv, y), FTimes, z) when y = z -> x | BinOp (UnOp (NumToInt, x), Equal, y) | BinOp (y, Equal, UnOp (NumToInt, x)) -> BinOp (UnOp (IntToNum, y), Equal, x) (* BinOps: Equalities (strings) *) @@ -1865,7 +1816,7 @@ and reduce_lexpr_loop let left = f left in match Expr.as_boolean_expr left with | None -> BinOp (left, Impl, f right) - | Some (Lit (Bool true), _) -> f right + | Some (Lit (Bool true), _) -> right | Some (Lit (Bool false), _) -> Expr.true_ | Some (left_f, _) -> let pfs_with_left = PFS.copy pfs in @@ -2011,47 +1962,18 @@ and reduce_lexpr_loop op in match op with + | Equal when Expr.equal flel fler -> Expr.true_ | Equal -> ( - let- () = - if Expr.equal flel fler then Some Expr.true_ - (* This made sense when Expr!=Formula, because maybe we have the expr = while - knowing the formula = is true. - But now this always returns true, since the expr is always a formula. - Maybe add a flag, so it only happens if this isn't the "top level"? - - else if - PFS.exists - (fun e -> - Expr.equal e (BinOp (flel, Equal, fler)) - || Expr.equal e (BinOp (fler, Equal, flel))) - pfs - then Some Expr.true_ *) - - (* Same with this, eg. if we're reducing (! (a == b)), it then tries to reduce - (a == b), and of course its negation is in the PFS. - - else if - PFS.exists - (fun e -> - Expr.equal e (UnOp (Not, BinOp (flel, Equal, fler))) - || Expr.equal e (UnOp (Not, BinOp (fler, Equal, flel)))) - pfs - then Some Expr.false_*) - else None - in (* TODO: Here we don't use the 2nd param, is that ok? *) let t1, _ = Typing.type_lexpr gamma flel in let t2, _ = Typing.type_lexpr gamma fler in + let is_type typ = Option.fold ~none:true ~some:(Type.equal typ) in let- () = match (t1, t2) with | Some t1, Some t2 when t1 <> t2 -> Some Expr.false_ | _, _ -> None in match (flel, fler) with - (* "RPFS" only? whatever that meant it's here now. *) - (* How does this make any sense?? l1 = l2 <=/=> len(l1) = len(l2) - | NOp (LstCat, _), LVar y when (* rpfs && *) prefix_catch pfs flel y - -> BinOp (UnOp (LstLen, flel), Equal, UnOp (LstLen, fler)) *) (* Lists *) | EList [], x | x, EList [] | Lit (LList []), x | x, Lit (LList []) -> ( @@ -2082,7 +2004,7 @@ and reduce_lexpr_loop when (match (flel, fler) with | LVar _, _ | _, LVar _ -> false | _ -> true) - && lexpr_is_list gamma flel && lexpr_is_list gamma fler -> ( + && is_type Type.ListType t1 && is_type Type.ListType t2 -> ( let htl1, htl2 = ( get_head_and_tail_of_list ~pfs flel, get_head_and_tail_of_list ~pfs fler ) @@ -2094,10 +2016,12 @@ and reduce_lexpr_loop | Some _, None, _, (Lit (LList _) | EList _) -> Expr.false_ | _ -> def) (* FPlus theory -> theory? I would not go that far *) - | _, _ when lexpr_is_number flel && lexpr_is_number fler -> + | _, _ when is_type Type.NumberType t1 && is_type Type.NumberType t2 + -> let success, le1', le2' = Cnum.cut flel fler in if success then BinOp (le1', Equal, le2') else def - | le1, le2 when lexpr_is_int le1 && lexpr_is_int le2 -> + | le1, le2 when is_type Type.IntType t1 && is_type Type.IntType t2 + -> let success, le1', le2' = Cint.cut le1 le2 in if success then BinOp (le1', Equal, le2') else def | _, _ -> def) @@ -2167,7 +2091,7 @@ and reduce_lexpr_loop | x, Lit (String "") | Lit (String ""), x -> x (* Rest *) | BinOp (el, StrCat, Lit (String s1)), Lit (String s2) -> - f (BinOp (el, StrCat, Lit (String (s1 ^ s2)))) + BinOp (el, StrCat, Lit (String (s1 ^ s2))) | _, _ -> def) | SetDiff when lexpr_is_set gamma def -> ( let pfs = PFS.to_list pfs in @@ -2179,10 +2103,7 @@ and reduce_lexpr_loop | x, ESet [] -> x | ESet left, ESet right when Expr.all_literals left && Expr.all_literals right -> - ESet - (Expr.Set.elements - (Expr.Set.diff (Expr.Set.of_list left) - (Expr.Set.of_list right))) + ESet Expr.Set.(elements (diff (of_list left) (of_list right))) | ESet left, s when Expr.all_literals left -> if List.for_all (fun x -> set_member pfs x s) left then ESet [] @@ -2190,9 +2111,7 @@ and reduce_lexpr_loop | ESet left, ESet right -> L.verbose (fun fmt -> fmt "Inside relevant SetDiff case."); let candidate_result = - Expr.Set.elements - (Expr.Set.diff (Expr.Set.of_list left) - (Expr.Set.of_list right)) + Expr.Set.(elements (diff (of_list left) (of_list right))) in L.verbose (fun fmt -> fmt "Candidate result: %a" @@ -2214,25 +2133,20 @@ and reduce_lexpr_loop in NOp (SetUnion, diffs) | _, NOp (SetUnion, les) -> - f - (NOp - ( SetInter, - List.map (fun le -> Expr.BinOp (flel, SetDiff, le)) les - )) + NOp + ( SetInter, + List.map (fun le -> Expr.BinOp (flel, SetDiff, le)) les ) | x, ESet [ el ] when List.mem (Expr.UnOp (Not, BinOp (el, SetMem, x))) pfs -> x | LVar _, _ -> if set_subset pfs flel fler then ESet [] else def - | ESet les, fler -> ( + | ESet les, fler when all_different pfs les -> (* We must know that the elements of les are all different, and for that we need the pure formulae *) - match all_different pfs les with - | false -> def - | true -> - let _, rest = - List.partition (fun x -> set_member pfs x fler) les - in - if List.for_all (fun x -> not_set_member pfs x fler) rest - then ESet rest - else BinOp (ESet rest, SetDiff, fler)) + let _, rest = + List.partition (fun x -> set_member pfs x fler) les + in + if List.for_all (fun x -> not_set_member pfs x fler) rest then + ESet rest + else BinOp (ESet rest, SetDiff, fler) | _, _ -> def) (* let hM = f (BinOp (flel, SetSub, fler)) in (match hM with @@ -2266,8 +2180,7 @@ and reduce_lexpr_loop | _, _ -> def) | FLessThan -> let success, el, er = Cnum.cut flel fler in - let nexpr = Expr.BinOp (el, FLessThan, er) in - if success then f nexpr else nexpr + if success then Expr.BinOp (el, FLessThan, er) else def | ILessThan -> ( match (flel, fler) with | x, fler @@ -2275,22 +2188,14 @@ and reduce_lexpr_loop match fler_len with | UnOp (LstLen, _) -> true | _ -> false -> - f - (BinOp - (BinOp (x, IPlus, Lit (Int Z.one)), ILessThanEqual, fler)) + BinOp (BinOp (x, IPlus, Lit (Int Z.one)), ILessThanEqual, fler) | UnOp (LstLen, _), Lit (Int n) when Z.leq n Z.zero -> Lit (Bool false) | UnOp (LstLen, le), Lit (Int z) when Z.equal z Z.one -> BinOp (le, Equal, EList []) | _ -> - let _, el, er = Cint.cut flel fler in - Expr.BinOp (el, ILessThan, er) - (* if success then f nexpr else nexpr *) - (* | _, _ -> - f - (BinOp - (BinOp (flel, FMinus, fler), FLessThan, Lit (Num 0.))) *) - ) + let success, el, er = Cint.cut flel fler in + if success then Expr.BinOp (el, ILessThan, er) else def) | FLessThanEqual -> ( let success, el, er = Cnum.cut flel fler in if success then BinOp (el, FLessThanEqual, er) From 81114752624162f47b80bdaf0f5cc6069a9a47ce Mon Sep 17 00:00:00 2001 From: N1ark Date: Tue, 7 Jan 2025 10:36:17 +0100 Subject: [PATCH 54/54] Fix `forall` precedences (thanks @v-gb !) --- Gillian-C/lib/MonadicSVal.ml | 12 +++++++----- Gillian-C2/lib/memory_model/SVal.ml | 7 ++++--- 2 files changed, 11 insertions(+), 8 deletions(-) diff --git a/Gillian-C/lib/MonadicSVal.ml b/Gillian-C/lib/MonadicSVal.ml index 948ee341..12850bc9 100644 --- a/Gillian-C/lib/MonadicSVal.ml +++ b/Gillian-C/lib/MonadicSVal.ml @@ -237,8 +237,10 @@ module SVArray = struct fmt "Undefined pf: not as concrete: %a" Expr.pp size); let i = LVar.alloc () in let i_e = Expr.LVar i in - forall [ (i, Some IntType) ] zero <= i_e - && i_e < size ==> (Expr.list_nth_e arr_exp i_e == Lit Undefined) + forall + [ (i, Some IntType) ] + ((zero <= i_e && i_e < size) + ==> (Expr.list_nth_e arr_exp i_e == Lit Undefined)) let zeros_pf ?size arr_exp = let size = @@ -259,12 +261,12 @@ module SVArray = struct | _ -> Logging.verbose (fun fmt -> fmt "Zeros pf: not as concrete: %a" Expr.pp size); - let is_zero e = e == Expr.int 0 in let i = LVar.alloc () in let i_e = Expr.LVar i in let zero = Expr.int 0 in - forall [ (i, Some IntType) ] zero <= i_e - && i_e < size ==> is_zero (Expr.list_nth_e arr_exp i_e) + forall + [ (i, Some IntType) ] + ((zero <= i_e && i_e < size) ==> (Expr.list_nth_e arr_exp i_e == zero)) let to_arr_with_size arr s = let open Expr.Infix in diff --git a/Gillian-C2/lib/memory_model/SVal.ml b/Gillian-C2/lib/memory_model/SVal.ml index 04612eca..a67706ab 100644 --- a/Gillian-C2/lib/memory_model/SVal.ml +++ b/Gillian-C2/lib/memory_model/SVal.ml @@ -290,15 +290,16 @@ module SVArray = struct fmt "Zeros pf: not as concrete: %a" Expr.pp size); let values_var = LVar.alloc () in let values = Expr.LVar values_var in - let is_zero e = e == Expr.int 0 in let i = LVar.alloc () in let i_e = Expr.LVar i in let zero = Expr.zero_i in let learned_types = [ (values_var, Type.ListType) ] in let correct_length = Expr.list_length values == size in let all_zero = - forall [ (i, Some IntType) ] zero <= i_e - && i_e < size ==> is_zero (Expr.list_nth_e values i_e) + forall + [ (i, Some IntType) ] + ((zero <= i_e && i_e < size) + ==> (Expr.list_nth_e values i_e == zero)) in return ~learned:[ correct_length; all_zero ] ~learned_types values