diff --git a/sledge/nonstdlib/set.ml b/sledge/nonstdlib/set.ml index c440fd000..72a684f7e 100644 --- a/sledge/nonstdlib/set.ml +++ b/sledge/nonstdlib/set.ml @@ -118,11 +118,20 @@ end) : S with type elt = Elt.t = struct let to_iter = S.to_iter let of_iter = S.of_iter - let pp ?pre ?suf ?(sep = (",@ " : (unit, unit) fmt)) pp_elt fs x = + let pp_full ?pre ?suf ?(sep = (",@ " : (unit, unit) fmt)) pp_elt fs x = List.pp ?pre ?suf sep pp_elt fs (S.elements x) - let pp_diff pp_elt fs (xs, ys) = - let lose = diff xs ys and gain = diff ys xs in - if not (is_empty lose) then Format.fprintf fs "-- %a" (pp pp_elt) lose ; - if not (is_empty gain) then Format.fprintf fs "++ %a" (pp pp_elt) gain + module Provide_pp (Elt : sig + type t = elt + + val pp : t pp + end) = + struct + let pp = pp_full Elt.pp + + let pp_diff fs (xs, ys) = + let lose = diff xs ys and gain = diff ys xs in + if not (is_empty lose) then Format.fprintf fs "-- %a" pp lose ; + if not (is_empty gain) then Format.fprintf fs "++ %a" pp gain + end end diff --git a/sledge/nonstdlib/set_intf.ml b/sledge/nonstdlib/set_intf.ml index bebf75802..b06520e7c 100644 --- a/sledge/nonstdlib/set_intf.ml +++ b/sledge/nonstdlib/set_intf.ml @@ -25,6 +25,27 @@ module type S = sig end with type t := t + (** {1 Pretty-print} *) + + val pp_full : + ?pre:(unit, unit) fmt + -> ?suf:(unit, unit) fmt + -> ?sep:(unit, unit) fmt + -> elt pp + -> t pp + + module Provide_pp (_ : sig + type t = elt + + val pp : t pp + end) : sig + type t + + val pp : t pp + val pp_diff : (t * t) pp + end + with type t := t + (** {1 Construct} *) val empty : t @@ -75,15 +96,4 @@ module type S = sig val to_iter : t -> elt iter val of_iter : elt iter -> t - - (** {1 Pretty-print} *) - - val pp : - ?pre:(unit, unit) fmt - -> ?suf:(unit, unit) fmt - -> ?sep:(unit, unit) fmt - -> elt pp - -> t pp - - val pp_diff : elt pp -> (t * t) pp end diff --git a/sledge/src/control.ml b/sledge/src/control.ml index 7cab46304..d767a339d 100644 --- a/sledge/src/control.ml +++ b/sledge/src/control.ml @@ -211,21 +211,23 @@ module Make (Opts : Domain_intf.Opts) (Dom : Domain_intf.Dom) = struct type elt = {depth: int; edge: Edge.t; state: Dom.t; depths: Depths.t} [@@deriving compare, sexp_of] - module Elts = Set.Make (struct + module Elt = struct type t = elt [@@deriving compare, sexp_of] - end) - type t = {queue: elt FHeap.t; removed: Elts.t} + let pp ppf {depth; edge} = + Format.fprintf ppf "%i: %a" depth Edge.pp edge + end - let pp_elt ppf {depth; edge} = - Format.fprintf ppf "%i: %a" depth Edge.pp edge + module Elts = Set.Make (Elt) + + type t = {queue: elt FHeap.t; removed: Elts.t} let pp ppf {queue; removed} = let rev_elts = FHeap.fold queue ~init:[] ~f:(fun rev_elts elt -> if Elts.mem elt removed then rev_elts else elt :: rev_elts ) in - Format.fprintf ppf "@[%a@]" (List.pp " ::@ " pp_elt) + Format.fprintf ppf "@[%a@]" (List.pp " ::@ " Elt.pp) (List.rev rev_elts) let create () = diff --git a/sledge/src/fol/exp.ml b/sledge/src/fol/exp.ml index df24f3434..032031dc8 100644 --- a/sledge/src/fol/exp.ml +++ b/sledge/src/fol/exp.ml @@ -193,15 +193,15 @@ module Term = struct one step. *) module T = struct type t = exp [@@deriving compare, equal, sexp] + + let ppx = ppx + let pp = pp end include T module Set = Set.Make (T) module Map = Map.Make (T) - let ppx = ppx - let pp = pp - (* variables *) let var v = `Trm (v : var :> trm) diff --git a/sledge/src/fol/fml.ml b/sledge/src/fol/fml.ml index fe84fff36..f13441540 100644 --- a/sledge/src/fol/fml.ml +++ b/sledge/src/fol/fml.ml @@ -43,11 +43,11 @@ let ppx strength fs fml = else pp_arith_op p_c op n_d in let pp_join sep pos neg = - pf "(%a%t%a)" (Set.pp ~sep pp) pos + pf "(%a%t%a)" (Set.pp_full ~sep pp) pos (fun ppf -> if (not (Set.is_empty pos)) && not (Set.is_empty neg) then Format.fprintf ppf sep ) - (Set.pp ~sep (fun fs fml -> pp fs (_Not fml))) + (Set.pp_full ~sep (fun fs fml -> pp fs (_Not fml))) neg in match fml with diff --git a/sledge/src/fol/var0.ml b/sledge/src/fol/var0.ml index ec355703c..a0fb1f08d 100644 --- a/sledge/src/fol/var0.ml +++ b/sledge/src/fol/var0.ml @@ -9,23 +9,28 @@ open Var_intf (** Variables, parameterized over their representation *) module Make (T : REPR) = struct - include T - - type nonrec strength = t strength - - let ppx strength ppf v = - let id = id v in - let name = name v in - let pp_id ppf id = if id <> 0 then Format.fprintf ppf "_%d" id in - match strength v with - | None -> - if id = 0 then Trace.pp_styled `Bold "%%%s" ppf name - else Format.fprintf ppf "%%%s%a" name pp_id id - | Some `Universal -> Trace.pp_styled `Bold "%%%s%a" ppf name pp_id id - | Some `Existential -> Trace.pp_styled `Cyan "%%%s%a" ppf name pp_id id - | Some `Anonymous -> Trace.pp_styled `Cyan "_" ppf + module T = struct + include T + + type nonrec strength = t strength + + let ppx strength ppf v = + let id = id v in + let name = name v in + let pp_id ppf id = if id <> 0 then Format.fprintf ppf "_%d" id in + match strength v with + | None -> + if id = 0 then Trace.pp_styled `Bold "%%%s" ppf name + else Format.fprintf ppf "%%%s%a" name pp_id id + | Some `Universal -> Trace.pp_styled `Bold "%%%s%a" ppf name pp_id id + | Some `Existential -> + Trace.pp_styled `Cyan "%%%s%a" ppf name pp_id id + | Some `Anonymous -> Trace.pp_styled `Cyan "_" ppf + + let pp = ppx (fun _ -> None) + end - let pp = ppx (fun _ -> None) + include T module Map = struct include NS.Map.Make (T) @@ -33,13 +38,12 @@ module Make (T : REPR) = struct end module Set = struct - let pp_t = pp - - include NS.Set.Make (T) + module S = NS.Set.Make (T) + include S include Provide_of_sexp (T) + include Provide_pp (T) - let ppx strength vs = pp (ppx strength) vs - let pp vs = pp pp_t vs + let ppx strength vs = S.pp_full (ppx strength) vs let pp_xs fs xs = if not (is_empty xs) then diff --git a/sledge/src/fol/var_intf.ml b/sledge/src/fol/var_intf.ml index f363467f0..86457c06f 100644 --- a/sledge/src/fol/var_intf.ml +++ b/sledge/src/fol/var_intf.ml @@ -36,6 +36,7 @@ module type VAR = sig val ppx : strength -> t pp val pp : t pp val pp_xs : t pp + val pp_diff : (t * t) pp end val id : t -> int diff --git a/sledge/src/llair/exp.ml b/sledge/src/llair/exp.ml index 636c5cc1c..c152cc99e 100644 --- a/sledge/src/llair/exp.ml +++ b/sledge/src/llair/exp.ml @@ -73,6 +73,89 @@ module T = struct | Ap3 of op3 * Typ.t * t * t * t | ApN of opN * Typ.t * t iarray [@@deriving compare, equal, hash, sexp] + + let demangle = ref (fun _ -> None) + + let pp_demangled ppf name = + match !demangle name with + | Some demangled when not (String.equal name demangled) -> + Format.fprintf ppf "“%s”" demangled + | _ -> () + + let pp_op2 fs op = + let pf fmt = Format.fprintf fs fmt in + match op with + | Eq -> pf "=" + | Dq -> pf "@<1>≠" + | Gt -> pf ">" + | Ge -> pf "@<1>≥" + | Lt -> pf "<" + | Le -> pf "@<1>≤" + | Ugt -> pf "u>" + | Uge -> pf "@<2>u≥" + | Ult -> pf "u<" + | Ule -> pf "@<2>u≤" + | Ord -> pf "ord" + | Uno -> pf "uno" + | Add -> pf "+" + | Sub -> pf "-" + | Mul -> pf "@<1>×" + | Div -> pf "/" + | Udiv -> pf "udiv" + | Rem -> pf "rem" + | Urem -> pf "urem" + | And -> pf "&&" + | Or -> pf "||" + | Xor -> pf "xor" + | Shl -> pf "shl" + | Lshr -> pf "lshr" + | Ashr -> pf "ashr" + | Update idx -> pf "[_|%i→_]" idx + + let rec pp fs exp = + let pf fmt = + Format.pp_open_box fs 2 ; + Format.kfprintf (fun fs -> Format.pp_close_box fs ()) fs fmt + in + match exp with + | Reg {name} -> pf "%%%s" name + | Global {name} -> pf "%@%s%a" name pp_demangled name + | Function {name} -> pf "&%s%a" name pp_demangled name + | Label {name} -> pf "%s" name + | Integer {data; typ= Pointer _} when Z.equal Z.zero data -> pf "null" + | Integer {data} -> Trace.pp_styled `Magenta "%a" fs Z.pp data + | Float {data} -> pf "%s" data + | Ap1 (Signed {bits}, dst, arg) -> + pf "((%a)(s%i)@ %a)" Typ.pp dst bits pp arg + | Ap1 (Unsigned {bits}, dst, arg) -> + pf "((%a)(u%i)@ %a)" Typ.pp dst bits pp arg + | Ap1 (Convert {src}, dst, arg) -> + pf "((%a)(%a)@ %a)" Typ.pp dst Typ.pp src pp arg + | Ap1 (Splat, _, byt) -> pf "%a^" pp byt + | Ap1 (Select idx, _, rcd) -> pf "%a[%i]" pp rcd idx + | Ap2 (Update idx, _, rcd, elt) -> + pf "[%a@ @[| %i → %a@]]" pp rcd idx pp elt + | Ap2 (Xor, Integer {bits= 1}, Integer {data}, x) when Z.is_true data -> + pf "¬%a" pp x + | Ap2 (Xor, Integer {bits= 1}, x, Integer {data}) when Z.is_true data -> + pf "¬%a" pp x + | Ap2 (op, _, x, y) -> pf "(%a@ %a %a)" pp x pp_op2 op pp y + | Ap3 (Conditional, _, cnd, thn, els) -> + pf "(%a@ ? %a@ : %a)" pp cnd pp thn pp els + | ApN (Record, _, elts) -> pf "{%a}" pp_record elts + [@@warning "-9"] + + and pp_record fs elts = + match + String.init (IArray.length elts) ~f:(fun i -> + match IArray.get elts i with + | Integer {data; typ= Integer {byts= 1; _}} -> + Char.of_int_exn (Z.to_int data) + | _ -> raise_notrace (Invalid_argument "not a string") ) + with + | s -> Format.fprintf fs "@[%s@]" (String.escaped s) + | exception _ -> + Format.fprintf fs "@[%a@]" (IArray.pp ",@ " pp) elts end include T @@ -86,88 +169,6 @@ end module Map = Map.Make (T) module Tbl = HashTable.Make (T) -let demangle = ref (fun _ -> None) - -let pp_demangled ppf name = - match !demangle name with - | Some demangled when not (String.equal name demangled) -> - Format.fprintf ppf "“%s”" demangled - | _ -> () - -let pp_op2 fs op = - let pf fmt = Format.fprintf fs fmt in - match op with - | Eq -> pf "=" - | Dq -> pf "@<1>≠" - | Gt -> pf ">" - | Ge -> pf "@<1>≥" - | Lt -> pf "<" - | Le -> pf "@<1>≤" - | Ugt -> pf "u>" - | Uge -> pf "@<2>u≥" - | Ult -> pf "u<" - | Ule -> pf "@<2>u≤" - | Ord -> pf "ord" - | Uno -> pf "uno" - | Add -> pf "+" - | Sub -> pf "-" - | Mul -> pf "@<1>×" - | Div -> pf "/" - | Udiv -> pf "udiv" - | Rem -> pf "rem" - | Urem -> pf "urem" - | And -> pf "&&" - | Or -> pf "||" - | Xor -> pf "xor" - | Shl -> pf "shl" - | Lshr -> pf "lshr" - | Ashr -> pf "ashr" - | Update idx -> pf "[_|%i→_]" idx - -let rec pp fs exp = - let pf fmt = - Format.pp_open_box fs 2 ; - Format.kfprintf (fun fs -> Format.pp_close_box fs ()) fs fmt - in - match exp with - | Reg {name} -> pf "%%%s" name - | Global {name} -> pf "%@%s%a" name pp_demangled name - | Function {name} -> pf "&%s%a" name pp_demangled name - | Label {name} -> pf "%s" name - | Integer {data; typ= Pointer _} when Z.equal Z.zero data -> pf "null" - | Integer {data} -> Trace.pp_styled `Magenta "%a" fs Z.pp data - | Float {data} -> pf "%s" data - | Ap1 (Signed {bits}, dst, arg) -> - pf "((%a)(s%i)@ %a)" Typ.pp dst bits pp arg - | Ap1 (Unsigned {bits}, dst, arg) -> - pf "((%a)(u%i)@ %a)" Typ.pp dst bits pp arg - | Ap1 (Convert {src}, dst, arg) -> - pf "((%a)(%a)@ %a)" Typ.pp dst Typ.pp src pp arg - | Ap1 (Splat, _, byt) -> pf "%a^" pp byt - | Ap1 (Select idx, _, rcd) -> pf "%a[%i]" pp rcd idx - | Ap2 (Update idx, _, rcd, elt) -> - pf "[%a@ @[| %i → %a@]]" pp rcd idx pp elt - | Ap2 (Xor, Integer {bits= 1}, Integer {data}, x) when Z.is_true data -> - pf "¬%a" pp x - | Ap2 (Xor, Integer {bits= 1}, x, Integer {data}) when Z.is_true data -> - pf "¬%a" pp x - | Ap2 (op, _, x, y) -> pf "(%a@ %a %a)" pp x pp_op2 op pp y - | Ap3 (Conditional, _, cnd, thn, els) -> - pf "(%a@ ? %a@ : %a)" pp cnd pp thn pp els - | ApN (Record, _, elts) -> pf "{%a}" pp_record elts - [@@warning "-9"] - -and pp_record fs elts = - match - String.init (IArray.length elts) ~f:(fun i -> - match IArray.get elts i with - | Integer {data; typ= Integer {byts= 1; _}} -> - Char.of_int_exn (Z.to_int data) - | _ -> raise_notrace (Invalid_argument "not a string") ) - with - | s -> Format.fprintf fs "@[%s@]" (String.escaped s) - | exception _ -> Format.fprintf fs "@[%a@]" (IArray.pp ",@ " pp) elts - (** Invariant *) let valid_idx idx elts = 0 <= idx && idx < IArray.length elts @@ -281,18 +282,13 @@ and typ_of exp = typ [@@warning "-9"] -let pp_exp = pp - (** Registers are the expressions constructed by [Reg] *) module Reg = struct include T - let pp = pp - module Set = struct include Set - - let pp = Set.pp pp_exp + include Provide_pp (T) end let invariant x = @@ -313,12 +309,9 @@ end module Global = struct include T - let pp = pp - module Set = struct include Set - - let pp = Set.pp pp_exp + include Provide_pp (T) end let invariant x = @@ -339,7 +332,6 @@ end module Function = struct include T - let pp = pp let name = function Function x -> x.name | r -> violates invariant r let typ = function Function x -> x.typ | r -> violates invariant r diff --git a/sledge/src/sh.ml b/sledge/src/sh.ml index eca9fc37d..4793d9017 100644 --- a/sledge/src/sh.ml +++ b/sledge/src/sh.ml @@ -182,8 +182,7 @@ let pp_us ?vs fs us = [%Trace.fprintf fs "@<2>∀ @[%a@] .@ " Var.Set.pp us] | Some vs -> if not (Var.Set.equal vs us) then - [%Trace.fprintf - fs "@<2>∀ @[%a@] .@ " (Var.Set.pp_diff Var.pp) (vs, us)] + [%Trace.fprintf fs "@<2>∀ @[%a@] .@ " Var.Set.pp_diff (vs, us)] let rec pp_ ?var_strength ?vs ancestor_xs parent_ctx fs {us; xs; ctx; pure; heap; djns} =