[sledge] Distinguish program expressions and formula terms

Summary:
There are a number if issues with using the same type for expressions
in code and in formulas. One is that the type systems of the two
should be different. Another is that conflating the two compromises
the ability of Llair to correctly express aspects such as integer
overflow, floating point rounding, etc. Also, it could be beneficial
to have more source locations for program expressions than makes sense
for terms.

This diff simply unshares Exp, leading to a copy named Term. Likewise,
Reg is now a copy of Var. Simplifications to come.

Reviewed By: bennostein

Differential Revision: D17665250

fbshipit-source-id: 4359a80d5
master
Josh Berdine 5 years ago committed by Facebook Github Bot
parent 13c06e4dd3
commit 442c8e92f4

@ -13,7 +13,7 @@ type exec_opts =
{ bound: int { bound: int
; skip_throw: bool ; skip_throw: bool
; function_summaries: bool ; function_summaries: bool
; globals: [`Per_function of Var.Set.t Var.Map.t | `Declared of Var.Set.t] ; globals: [`Per_function of Reg.Set.t Reg.Map.t | `Declared of Reg.Set.t]
} }
module Make (Dom : Domain_sig.Dom) = struct module Make (Dom : Domain_sig.Dom) = struct
@ -31,15 +31,15 @@ module Make (Dom : Domain_sig.Dom) = struct
val pop_throw : val pop_throw :
t t
-> init:'a -> init:'a
-> unwind:(Var.t list -> Var.Set.t -> Dom.from_call -> 'a -> 'a) -> unwind:(Reg.t list -> Reg.Set.t -> Dom.from_call -> 'a -> 'a)
-> (Dom.from_call * Llair.jump * t * 'a) option -> (Dom.from_call * Llair.jump * t * 'a) option
end = struct end = struct
type t = type t =
| Return of | Return of
{ recursive: bool (** return from a possibly-recursive call *) { recursive: bool (** return from a possibly-recursive call *)
; dst: Llair.Jump.t ; dst: Llair.Jump.t
; params: Var.t list ; params: Reg.t list
; locals: Var.Set.t ; locals: Reg.Set.t
; from_call: Dom.from_call ; from_call: Dom.from_call
; stk: t } ; stk: t }
| Throw of Llair.Jump.t * t | Throw of Llair.Jump.t * t
@ -248,9 +248,9 @@ module Make (Dom : Domain_sig.Dom) = struct
| None -> [%Trace.info "queue empty"] ; () | None -> [%Trace.info "queue empty"] ; ()
end end
let used_globals : exec_opts -> Var.var -> Var.Set.t = let used_globals : exec_opts -> Reg.reg -> Reg.Set.t =
fun opts fn -> fun opts fn ->
[%Trace.call fun {pf} -> pf "%a" Var.pp fn] [%Trace.call fun {pf} -> pf "%a" Reg.pp fn]
; ;
( match opts.globals with ( match opts.globals with
| `Declared set -> set | `Declared set -> set
@ -261,21 +261,21 @@ module Make (Dom : Domain_sig.Dom) = struct
fail fail
"main analysis reached function %a that was not reached by \ "main analysis reached function %a that was not reached by \
used-globals pre-analysis " used-globals pre-analysis "
Var.pp fn () ) ) Reg.pp fn () ) )
|> |>
[%Trace.retn fun {pf} r -> pf "%a" Var.Set.pp r] [%Trace.retn fun {pf} r -> pf "%a" Reg.Set.pp r]
let exec_jump stk state block Llair.{dst; retreating} = let exec_jump stk state block Llair.{dst; retreating} =
Work.add ~prev:block ~retreating stk state dst Work.add ~prev:block ~retreating stk state dst
let summary_table = Hashtbl.create (module Var) let summary_table = Hashtbl.create (module Reg)
let exec_call opts stk state block call globals = let exec_call opts stk state block call globals =
let Llair.{callee; args; areturn; return; recursive} = call in let Llair.{callee; args; areturn; return; recursive} = call in
let Llair.{name; params; freturn; locals; entry} = callee in let Llair.{name; params; freturn; locals; entry} = callee in
[%Trace.call fun {pf} -> [%Trace.call fun {pf} ->
pf "%a from %a with state %a" Var.pp name.var Var.pp pf "%a from %a with state %a" Reg.pp name.reg Reg.pp
return.dst.parent.name.var Dom.pp state] return.dst.parent.name.reg Dom.pp state]
; ;
let dnf_states = let dnf_states =
if opts.function_summaries then Dom.dnf state else [state] if opts.function_summaries then Dom.dnf state else [state]
@ -290,7 +290,7 @@ module Make (Dom : Domain_sig.Dom) = struct
else else
let maybe_summary_post = let maybe_summary_post =
let state = fst (domain_call ~summaries:false state) in let state = fst (domain_call ~summaries:false state) in
Hashtbl.find summary_table name.var Hashtbl.find summary_table name.reg
>>= List.find_map ~f:(Dom.apply_summary state) >>= List.find_map ~f:(Dom.apply_summary state)
in in
[%Trace.info [%Trace.info
@ -320,23 +320,23 @@ module Make (Dom : Domain_sig.Dom) = struct
[%Trace.printf [%Trace.printf
"@[<v>%t@]" (fun fs -> "@[<v>%t@]" (fun fs ->
Hashtbl.iteri summary_table ~f:(fun ~key ~data -> Hashtbl.iteri summary_table ~f:(fun ~key ~data ->
Format.fprintf fs "@[<v>%a:@ @[%a@]@]@ " Var.pp key Format.fprintf fs "@[<v>%a:@ @[%a@]@]@ " Reg.pp key
(List.pp "@," Dom.pp_summary) (List.pp "@," Dom.pp_summary)
data ) )] data ) )]
let exec_return ~opts stk pre_state (block : Llair.block) exp = let exec_return ~opts stk pre_state (block : Llair.block) exp =
let Llair.{name; params; freturn; locals} = block.parent in let Llair.{name; params; freturn; locals} = block.parent in
[%Trace.call fun {pf} -> [%Trace.call fun {pf} ->
pf "from %a with pre_state %a" Var.pp name.var Dom.pp pre_state] pf "from %a with pre_state %a" Reg.pp name.reg Dom.pp pre_state]
; ;
let summarize post_state = let summarize post_state =
if opts.function_summaries then ( if opts.function_summaries then (
let globals = used_globals opts name.var in let globals = used_globals opts name.reg in
let function_summary, post_state = let function_summary, post_state =
Dom.create_summary ~locals post_state Dom.create_summary ~locals post_state
~formals:(Set.union (Var.Set.of_list params) globals) ~formals:(Set.union (Reg.Set.of_list params) globals)
in in
Hashtbl.add_multi summary_table ~key:name.var ~data:function_summary ; Hashtbl.add_multi summary_table ~key:name.reg ~data:function_summary ;
pp_st () ; pp_st () ;
post_state ) post_state )
else post_state else post_state
@ -359,7 +359,7 @@ module Make (Dom : Domain_sig.Dom) = struct
opts.function_summaries opts.function_summaries
&& List.exists && List.exists
(Config.find_list "entry-points") (Config.find_list "entry-points")
~f:(String.equal (Var.name name.var)) ~f:(String.equal (Reg.name name.reg))
then summarize exit_state |> (ignore : Dom.t -> unit) ; then summarize exit_state |> (ignore : Dom.t -> unit) ;
Work.skip ) Work.skip )
|> |>
@ -367,7 +367,7 @@ module Make (Dom : Domain_sig.Dom) = struct
let exec_throw stk pre_state (block : Llair.block) exc = let exec_throw stk pre_state (block : Llair.block) exc =
let func = block.parent in let func = block.parent in
[%Trace.call fun {pf} -> pf "from %a" Var.pp func.name.var] [%Trace.call fun {pf} -> pf "from %a" Reg.pp func.name.reg]
; ;
let unwind params scope from_call state = let unwind params scope from_call state =
Dom.retn params (Some func.fthrow) from_call Dom.retn params (Some func.fthrow) from_call
@ -390,7 +390,7 @@ module Make (Dom : Domain_sig.Dom) = struct
Stack.t Stack.t
-> Dom.t -> Dom.t
-> Llair.block -> Llair.block
-> Var.t option -> Reg.t option
-> Llair.jump -> Llair.jump
-> Work.x = -> Work.x =
fun stk state block areturn return -> fun stk state block areturn return ->
@ -423,7 +423,7 @@ module Make (Dom : Domain_sig.Dom) = struct
Dom.exec_assume state Dom.exec_assume state
(Exp.eq ptr (Exp.eq ptr
(Exp.label (Exp.label
~parent:(Var.name jump.dst.parent.name.var) ~parent:(Reg.name jump.dst.parent.name.reg)
~name:jump.dst.lbl)) ~name:jump.dst.lbl))
with with
| Some state -> exec_jump stk state block jump |> Work.seq x | Some state -> exec_jump stk state block jump |> Work.seq x
@ -439,7 +439,7 @@ module Make (Dom : Domain_sig.Dom) = struct
List.fold callees ~init:Work.skip ~f:(fun x callee -> List.fold callees ~init:Work.skip ~f:(fun x callee ->
( match ( match
Dom.exec_intrinsic ~skip_throw:opts.skip_throw state Dom.exec_intrinsic ~skip_throw:opts.skip_throw state
areturn callee.name.var args areturn callee.name.reg args
with with
| Some (Error ()) -> | Some (Error ()) ->
Report.invalid_access_term Report.invalid_access_term
@ -452,7 +452,7 @@ module Make (Dom : Domain_sig.Dom) = struct
exec_skip_func stk state block areturn return exec_skip_func stk state block areturn return
| None -> | None ->
exec_call opts stk state block {call with callee} exec_call opts stk state block {call with callee}
(used_globals opts callee.name.var) ) (used_globals opts callee.name.reg) )
|> Work.seq x ) ) |> Work.seq x ) )
| Return {exp} -> exec_return ~opts stk state block exp | Return {exp} -> exec_return ~opts stk state block exp
| Throw {exc} -> | Throw {exc} ->
@ -481,12 +481,12 @@ module Make (Dom : Domain_sig.Dom) = struct
let entry_points = Config.find_list "entry-points" in let entry_points = Config.find_list "entry-points" in
List.find_map ~f:(Llair.Func.find pgm.functions) entry_points List.find_map ~f:(Llair.Func.find pgm.functions) entry_points
|> function |> function
| Some {name= {var}; locals; params= []; entry} -> | Some {name= {reg}; locals; params= []; entry} ->
Some Some
(Work.init (Work.init
(fst (fst
(Dom.call ~summaries:opts.function_summaries (Dom.call ~summaries:opts.function_summaries
~globals:(used_globals opts var) [] None [] ~locals ~globals:(used_globals opts reg) [] None [] ~locals
(Dom.init pgm.globals))) (Dom.init pgm.globals)))
entry) entry)
| _ -> None | _ -> None
@ -501,9 +501,9 @@ module Make (Dom : Domain_sig.Dom) = struct
|> |>
[%Trace.retn fun {pf} _ -> pf ""] [%Trace.retn fun {pf} _ -> pf ""]
let compute_summaries opts pgm : Dom.summary list Var.Map.t = let compute_summaries opts pgm : Dom.summary list Reg.Map.t =
assert opts.function_summaries ; assert opts.function_summaries ;
exec_pgm opts pgm ; exec_pgm opts pgm ;
Hashtbl.fold summary_table ~init:Var.Map.empty ~f:(fun ~key ~data map -> Hashtbl.fold summary_table ~init:Reg.Map.empty ~f:(fun ~key ~data map ->
match data with [] -> map | _ -> Map.set map ~key ~data ) match data with [] -> map | _ -> Map.set map ~key ~data )
end end

@ -11,11 +11,11 @@ type exec_opts =
{ bound: int (** Loop/recursion unrolling bound *) { bound: int (** Loop/recursion unrolling bound *)
; skip_throw: bool (** Treat throw as unreachable *) ; skip_throw: bool (** Treat throw as unreachable *)
; function_summaries: bool (** Use function summarisation *) ; function_summaries: bool (** Use function summarisation *)
; globals: [`Per_function of Var.Set.t Var.Map.t | `Declared of Var.Set.t] ; globals: [`Per_function of Reg.Set.t Reg.Map.t | `Declared of Reg.Set.t]
(** Either a per-function used-globals map or a program-wide set *) (** Either a per-function used-globals map or a program-wide set *)
} }
module Make (Dom : Domain_sig.Dom) : sig module Make (Dom : Domain_sig.Dom) : sig
val exec_pgm : exec_opts -> Llair.t -> unit val exec_pgm : exec_opts -> Llair.t -> unit
val compute_summaries : exec_opts -> Llair.t -> Dom.summary list Var.Map.t val compute_summaries : exec_opts -> Llair.t -> Dom.summary list Reg.Map.t
end end

@ -15,15 +15,15 @@ module type Dom = sig
val join : t -> t -> t option val join : t -> t -> t option
val is_false : t -> bool val is_false : t -> bool
val exec_assume : t -> Exp.t -> t option val exec_assume : t -> Exp.t -> t option
val exec_kill : t -> Var.t -> t val exec_kill : t -> Reg.t -> t
val exec_move : t -> Var.t -> Exp.t -> t val exec_move : t -> Reg.t -> Exp.t -> t
val exec_inst : t -> Llair.inst -> (t, unit) result val exec_inst : t -> Llair.inst -> (t, unit) result
val exec_intrinsic : val exec_intrinsic :
skip_throw:bool skip_throw:bool
-> t -> t
-> Var.t option -> Reg.t option
-> Var.t -> Reg.t
-> Exp.t list -> Exp.t list
-> (t, unit) result option -> (t, unit) result option
@ -31,17 +31,17 @@ module type Dom = sig
val call : val call :
summaries:bool summaries:bool
-> globals:Var.Set.t -> globals:Reg.Set.t
-> Exp.t list -> Exp.t list
-> Var.t option -> Reg.t option
-> Var.t list -> Reg.t list
-> locals:Var.Set.t -> locals:Reg.Set.t
-> t -> t
-> t * from_call -> t * from_call
val recursion_beyond_bound : [`skip | `prune] val recursion_beyond_bound : [`skip | `prune]
val post : Var.Set.t -> from_call -> t -> t val post : Reg.Set.t -> from_call -> t -> t
val retn : Var.t list -> Var.t option -> from_call -> t -> t val retn : Reg.t list -> Reg.t option -> from_call -> t -> t
val dnf : t -> t list val dnf : t -> t list
val resolve_callee : val resolve_callee :
@ -52,7 +52,7 @@ module type Dom = sig
val pp_summary : summary pp val pp_summary : summary pp
val create_summary : val create_summary :
locals:Var.Set.t -> formals:Var.Set.t -> t -> summary * t locals:Reg.Set.t -> formals:Reg.Set.t -> t -> summary * t
val apply_summary : t -> summary -> t option val apply_summary : t -> summary -> t option
end end

@ -12,8 +12,8 @@ module type State_domain_sig = sig
include Domain_sig.Dom include Domain_sig.Dom
val create_summary : val create_summary :
locals:Var.Set.t locals:Reg.Set.t
-> formals:Var.Set.t -> formals:Reg.Set.t
-> entry:t -> entry:t
-> current:t -> current:t
-> summary * t -> summary * t
@ -77,8 +77,8 @@ module Make (State_domain : State_domain_sig) = struct
pf pf
"@[<v>@[actuals: (@[%a@])@ formals: (@[%a@])@]@ locals: {@[%a@]}@ \ "@[<v>@[actuals: (@[%a@])@ formals: (@[%a@])@]@ locals: {@[%a@]}@ \
globals: {@[%a@]}@ current: %a@]" globals: {@[%a@]}@ current: %a@]"
(List.pp ",@ " Exp.pp) (List.rev actuals) (List.pp ",@ " Var.pp) (List.pp ",@ " Exp.pp) (List.rev actuals) (List.pp ",@ " Reg.pp)
(List.rev formals) Var.Set.pp locals Var.Set.pp globals (List.rev formals) Reg.Set.pp locals Reg.Set.pp globals
State_domain.pp current] State_domain.pp current]
; ;
let caller_current, state_from_call = let caller_current, state_from_call =
@ -91,7 +91,7 @@ module Make (State_domain : State_domain_sig) = struct
[%Trace.retn fun {pf} (reln, _) -> pf "@,%a" pp reln] [%Trace.retn fun {pf} (reln, _) -> pf "@,%a" pp reln]
let post locals {state_from_call; caller_entry} (_, current) = let post locals {state_from_call; caller_entry} (_, current) =
[%Trace.call fun {pf} -> pf "locals: %a" Var.Set.pp locals] [%Trace.call fun {pf} -> pf "locals: %a" Reg.Set.pp locals]
; ;
(caller_entry, State_domain.post locals state_from_call current) (caller_entry, State_domain.post locals state_from_call current)
|> |>

@ -12,8 +12,8 @@ module type State_domain_sig = sig
include Domain_sig.Dom include Domain_sig.Dom
val create_summary : val create_summary :
locals:Var.Set.t locals:Reg.Set.t
-> formals:Var.Set.t -> formals:Reg.Set.t
-> entry:t -> entry:t
-> current:t -> current:t
-> summary * t -> summary * t

@ -29,8 +29,8 @@ let retn _ _ _ _ = ()
let dnf () = [()] let dnf () = [()]
let resolve_callee lookup ptr _ = let resolve_callee lookup ptr _ =
match Var.of_exp ptr with match Reg.of_exp ptr with
| Some callee -> (lookup (Var.name callee), ()) | Some callee -> (lookup (Reg.name callee), ())
| None -> ([], ()) | None -> ([], ())
type summary = unit type summary = unit

@ -7,11 +7,11 @@
(** Used-globals abstract domain *) (** Used-globals abstract domain *)
type t = Var.Set.t [@@deriving equal, sexp_of] type t = Reg.Set.t [@@deriving equal, sexp_of]
let pp = Set.pp Var.pp let pp = Set.pp Reg.pp
let report_fmt_thunk = Fn.flip pp let report_fmt_thunk = Fn.flip pp
let empty = Var.Set.empty let empty = Reg.Set.empty
let init globals = let init globals =
[%Trace.info [%Trace.info
@ -24,10 +24,10 @@ let is_false _ = false
let post _ _ state = state let post _ _ state = state
let retn _ _ from_call post = Set.union from_call post let retn _ _ from_call post = Set.union from_call post
let dnf t = [t] let dnf t = [t]
let add_if_global gs v = if Var.global v then Set.add gs v else gs let add_if_global gs v = if Reg.global v then Set.add gs v else gs
let used_globals ?(init = empty) exp = let used_globals ?(init = empty) exp =
Exp.fold_vars exp ~init ~f:add_if_global Exp.fold_regs exp ~init ~f:add_if_global
let exec_assume st exp = Some (used_globals ~init:st exp) let exec_assume st exp = Some (used_globals ~init:st exp)
let exec_kill st _ = st let exec_kill st _ = st
@ -44,7 +44,7 @@ let exec_inst st inst =
Result.iter ~f:(fun uses -> pf "post:{%a}" pp uses)] Result.iter ~f:(fun uses -> pf "post:{%a}" pp uses)]
let exec_intrinsic ~skip_throw:_ st _ intrinsic actuals = let exec_intrinsic ~skip_throw:_ st _ intrinsic actuals =
let name = Var.name intrinsic in let name = Reg.name intrinsic in
if if
List.exists List.exists
[ "malloc"; "aligned_alloc"; "calloc"; "posix_memalign"; "realloc" [ "malloc"; "aligned_alloc"; "calloc"; "posix_memalign"; "realloc"
@ -66,11 +66,11 @@ let call ~summaries:_ ~globals:_ actuals _ _ ~locals:_ st =
let resolve_callee lookup ptr st = let resolve_callee lookup ptr st =
let st = used_globals ~init:st ptr in let st = used_globals ~init:st ptr in
match Var.of_exp ptr with match Reg.of_exp ptr with
| Some callee -> (lookup (Var.name callee), st) | Some callee -> (lookup (Reg.name callee), st)
| None -> ([], st) | None -> ([], st)
(* A function summary is the set of global variables accessed by that (* A function summary is the set of global registers accessed by that
function and its transitive callees *) function and its transitive callees *)
type summary = t type summary = t

@ -7,4 +7,4 @@
(** Used-globals abstract domain *) (** Used-globals abstract domain *)
include Domain_sig.Dom with type summary = Var.Set.t include Domain_sig.Dom with type summary = Reg.Set.t

@ -58,7 +58,7 @@ module rec T : sig
| Memory of {siz: t; arr: t} | Memory of {siz: t; arr: t}
| Concat of {args: t vector} | Concat of {args: t vector}
(* nullary *) (* nullary *)
| Var of {id: int; name: string; global: bool} | Reg of {id: int; name: string; global: bool}
| Nondet of {msg: string} | Nondet of {msg: string}
| Label of {parent: string; name: string} | Label of {parent: string; name: string}
(* curried application *) (* curried application *)
@ -123,7 +123,7 @@ and T0 : sig
| Splat of {byt: t; siz: t} | Splat of {byt: t; siz: t}
| Memory of {siz: t; arr: t} | Memory of {siz: t; arr: t}
| Concat of {args: t vector} | Concat of {args: t vector}
| Var of {id: int; name: string; global: bool} | Reg of {id: int; name: string; global: bool}
| Nondet of {msg: string} | Nondet of {msg: string}
| Label of {parent: string; name: string} | Label of {parent: string; name: string}
| App of {op: t; arg: t} | App of {op: t; arg: t}
@ -167,7 +167,7 @@ end = struct
| Splat of {byt: t; siz: t} | Splat of {byt: t; siz: t}
| Memory of {siz: t; arr: t} | Memory of {siz: t; arr: t}
| Concat of {args: t vector} | Concat of {args: t vector}
| Var of {id: int; name: string; global: bool} | Reg of {id: int; name: string; global: bool}
| Nondet of {msg: string} | Nondet of {msg: string}
| Label of {parent: string; name: string} | Label of {parent: string; name: string}
| App of {op: t; arg: t} | App of {op: t; arg: t}
@ -236,10 +236,10 @@ let uncurry =
uncurry_ [] uncurry_ []
let rec pp ?is_x fs exp = let rec pp ?is_x fs exp =
let get_var_style var = let get_reg_style reg =
match is_x with match is_x with
| None -> `None | None -> `None
| Some is_x -> if not (is_x var) then `Bold else `Cyan | Some is_x -> if not (is_x reg) then `Bold else `Cyan
in in
let pp_ pp fs exp = let pp_ pp fs exp =
let pf fmt = let pf fmt =
@ -247,12 +247,12 @@ let rec pp ?is_x fs exp =
Format.kfprintf (fun fs -> Format.pp_close_box fs ()) fs fmt Format.kfprintf (fun fs -> Format.pp_close_box fs ()) fs fmt
in in
match exp with match exp with
| Var {name; id= 0; global= true} as var -> | Reg {name; id= 0; global= true} as reg ->
Trace.pp_styled (get_var_style var) "%@%s" fs name Trace.pp_styled (get_reg_style reg) "%@%s" fs name
| Var {name; id= 0; global= false} as var -> | Reg {name; id= 0; global= false} as reg ->
Trace.pp_styled (get_var_style var) "%%%s" fs name Trace.pp_styled (get_reg_style reg) "%%%s" fs name
| Var {name; id; _} as var -> | Reg {name; id; _} as reg ->
Trace.pp_styled (get_var_style var) "%%%s_%d" fs name id Trace.pp_styled (get_reg_style reg) "%%%s_%d" fs name id
| Nondet {msg} -> pf "nondet \"%s\"" msg | Nondet {msg} -> pf "nondet \"%s\"" msg
| Label {name} -> pf "%s" name | Label {name} -> pf "%s" name
| Integer {data; typ= Pointer _} when Z.equal Z.zero data -> pf "null" | Integer {data; typ= Pointer _} when Z.equal Z.zero data -> pf "null"
@ -455,7 +455,7 @@ let invariant ?(partial = false) e =
assert_arity 0 ; assert_arity 0 ;
assert (Z.numbits data <= bits) ) assert (Z.numbits data <= bits) )
| Integer _ -> assert false | Integer _ -> assert false
| Var {id; global; _} -> | Reg {id; global; _} ->
assert_arity 0 ; assert_arity 0 ;
assert ((not global) || id = 0) assert ((not global) || id = 0)
| Nondet _ | Label _ | Float _ -> assert_arity 0 | Nondet _ | Label _ | Float _ -> assert_arity 0
@ -500,13 +500,13 @@ let bits_of_int exp =
| None -> violates invariant exp ) | None -> violates invariant exp )
| _ -> fail "bits_of_int" () | _ -> fail "bits_of_int" ()
(** Variables are the expressions constructed by [Var] *) (** Registers are the expressions constructed by [Reg] *)
module Var = struct module Reg = struct
include T include T
let pp = pp let pp = pp
type var = t type reg = t
module Set = struct module Set = struct
include ( include (
@ -553,7 +553,7 @@ module Var = struct
if !@status = 0 then demangled else None if !@status = 0 then demangled else None
let pp_demangled fs = function let pp_demangled fs = function
| Var {name} -> ( | Reg {name} -> (
match demangle name with match demangle name with
| Some demangled when not (String.equal name demangled) -> | Some demangled when not (String.equal name demangled) ->
Format.fprintf fs "“%s”" demangled Format.fprintf fs "“%s”" demangled
@ -562,25 +562,25 @@ module Var = struct
let invariant x = let invariant x =
Invariant.invariant [%here] x [%sexp_of: t] Invariant.invariant [%here] x [%sexp_of: t]
@@ fun () -> match x with Var _ -> invariant x | _ -> assert false @@ fun () -> match x with Reg _ -> invariant x | _ -> assert false
let id = function Var {id} -> id | x -> violates invariant x let id = function Reg {id} -> id | x -> violates invariant x
let name = function Var {name} -> name | x -> violates invariant x let name = function Reg {name} -> name | x -> violates invariant x
let global = function Var {global} -> global | x -> violates invariant x let global = function Reg {global} -> global | x -> violates invariant x
let of_exp = function let of_exp = function
| Var _ as v -> Some (v |> check invariant) | Reg _ as x -> Some (x |> check invariant)
| _ -> None | _ -> None
let program ?global name = let program ?global name =
Var {id= 0; name; global= Option.is_some global} |> check invariant Reg {id= 0; name; global= Option.is_some global} |> check invariant
let fresh name ~(wrt : Set.t) = let fresh name ~(wrt : Set.t) =
let max = match Set.max_elt wrt with None -> 0 | Some max -> id max in let max = match Set.max_elt wrt with None -> 0 | Some max -> id max in
let x' = Var {name; id= max + 1; global= false} in let x' = Reg {name; id= max + 1; global= false} in
(x', Set.add wrt x') (x', Set.add wrt x')
(** Variable renaming substitutions *) (** Register renaming substitutions *)
module Subst = struct module Subst = struct
type t = T.t Map.M(T).t [@@deriving compare, equal, sexp] type t = T.t Map.M(T).t [@@deriving compare, equal, sexp]
@ -675,15 +675,15 @@ let fold_exps e ~init ~f =
let iter_exps e ~f = fold_exps e ~init:() ~f:(fun () e -> f e) let iter_exps e ~f = fold_exps e ~init:() ~f:(fun () e -> f e)
let fold_vars e ~init ~f = let fold_regs e ~init ~f =
fold_exps e ~init ~f:(fun z -> function fold_exps e ~init ~f:(fun z -> function
| Var _ as v -> f z (v :> Var.t) | _ -> z ) | Reg _ as x -> f z (x :> Reg.t) | _ -> z )
let fv e = fold_vars e ~f:Set.add ~init:Var.Set.empty let fv e = fold_regs e ~f:Set.add ~init:Reg.Set.empty
(** Construct *) (** Construct *)
let var x = x let reg x = x
let nondet msg = Nondet {msg} |> check invariant let nondet msg = Nondet {msg} |> check invariant
let label ~parent ~name = Label {parent; name} |> check invariant let label ~parent ~name = Label {parent; name} |> check invariant
let integer data typ = Integer {data; typ} |> check invariant let integer data typ = Integer {data; typ} |> check invariant
@ -1331,7 +1331,7 @@ let map e ~f =
let rename sub e = let rename sub e =
let rec rename_ sub e = let rec rename_ sub e =
match e with match e with
| Var _ -> Var.Subst.apply sub e | Reg _ -> Reg.Subst.apply sub e
| _ -> map ~f:(rename_ sub) e | _ -> map ~f:(rename_ sub) e
in in
rename_ sub e |> check (invariant ~partial:true) rename_ sub e |> check (invariant ~partial:true)
@ -1349,7 +1349,7 @@ let is_false = function
let rec is_constant e = let rec is_constant e =
let is_constant_bin x y = is_constant x && is_constant y in let is_constant_bin x y = is_constant x && is_constant y in
match e with match e with
| Var _ | Nondet _ -> false | Reg _ | Nondet _ -> false
| App {op= x; arg= y} | Splat {byt= x; siz= y} | Memory {siz= x; arr= y} | App {op= x; arg= y} | Splat {byt= x; siz= y} | Memory {siz= x; arr= y}
-> ->
is_constant_bin x y is_constant_bin x y
@ -1413,4 +1413,4 @@ let solve e f =
solve_ e f empty_map solve_ e f empty_map
|> |>
[%Trace.retn fun {pf} -> [%Trace.retn fun {pf} ->
function Some s -> pf "%a" Var.Subst.pp s | None -> pf "false"] function Some s -> pf "%a" Reg.Subst.pp s | None -> pf "false"]

@ -27,10 +27,10 @@ and t = private
(** Iterated concatenation of a single byte *) (** Iterated concatenation of a single byte *)
| Memory of {siz: t; arr: t} (** Size-tagged byte-array *) | Memory of {siz: t; arr: t} (** Size-tagged byte-array *)
| Concat of {args: t vector} (** Byte-array concatenation *) | Concat of {args: t vector} (** Byte-array concatenation *)
| Var of {id: int; name: string; global: bool} | Reg of {id: int; name: string; global: bool}
(** Local variable / virtual register *) (** Local variable / virtual register *)
| Nondet of {msg: string} | Nondet of {msg: string}
(** Anonymous local variable with arbitrary value, representing (** Anonymous register with arbitrary value, representing
non-deterministic approximation of value described by [msg] *) non-deterministic approximation of value described by [msg] *)
| Label of {parent: string; name: string} | Label of {parent: string; name: string}
(** Address of named code block within parent function *) (** Address of named code block within parent function *)
@ -81,28 +81,28 @@ val pp_full : ?is_x:(exp -> bool) -> t pp
val pp : t pp val pp : t pp
val invariant : ?partial:bool -> t -> unit val invariant : ?partial:bool -> t -> unit
(** Exp.Var is re-exported as Var *) (** Exp.Reg is re-exported as Reg *)
module Var : sig module Reg : sig
type t = private exp [@@deriving compare, equal, hash, sexp] type t = private exp [@@deriving compare, equal, hash, sexp]
type var = t type reg = t
include Comparator.S with type t := t include Comparator.S with type t := t
module Set : sig module Set : sig
type t = (var, comparator_witness) Set.t type t = (reg, comparator_witness) Set.t
[@@deriving compare, equal, sexp] [@@deriving compare, equal, sexp]
val pp_full : ?is_x:(exp -> bool) -> t pp val pp_full : ?is_x:(exp -> bool) -> t pp
val pp : t pp val pp : t pp
val empty : t val empty : t
val of_option : var option -> t val of_option : reg option -> t
val of_list : var list -> t val of_list : reg list -> t
val of_vector : reg vector -> t
val union_list : t list -> t val union_list : t list -> t
val of_vector : var vector -> t
end end
module Map : sig module Map : sig
type 'a t = (var, 'a, comparator_witness) Map.t type 'a t = (reg, 'a, comparator_witness) Map.t
[@@deriving compare, equal, sexp] [@@deriving compare, equal, sexp]
val empty : 'a t val empty : 'a t
@ -126,7 +126,7 @@ module Var : sig
val pp : t pp val pp : t pp
val empty : t val empty : t
val freshen : Set.t -> wrt:Set.t -> t val freshen : Set.t -> wrt:Set.t -> t
val extend : t -> replace:var -> with_:var -> t val extend : t -> replace:reg -> with_:reg -> t
val invert : t -> t val invert : t -> t
val exclude : t -> Set.t -> t val exclude : t -> Set.t -> t
val restrict : t -> Set.t -> t val restrict : t -> Set.t -> t
@ -140,7 +140,7 @@ end
(** Construct *) (** Construct *)
val var : Var.t -> t val reg : Reg.t -> t
val nondet : string -> t val nondet : string -> t
val label : parent:string -> name:string -> t val label : parent:string -> name:string -> t
val null : t val null : t
@ -200,18 +200,18 @@ val size_of : Typ.t -> t option
(** Access *) (** Access *)
val iter : t -> f:(t -> unit) -> unit val iter : t -> f:(t -> unit) -> unit
val fold_vars : t -> init:'a -> f:('a -> Var.t -> 'a) -> 'a val fold_regs : t -> init:'a -> f:('a -> Reg.t -> 'a) -> 'a
val fold_exps : t -> init:'a -> f:('a -> t -> 'a) -> 'a val fold_exps : t -> init:'a -> f:('a -> t -> 'a) -> 'a
val fold : t -> init:'a -> f:(t -> 'a -> 'a) -> 'a val fold : t -> init:'a -> f:(t -> 'a -> 'a) -> 'a
(** Transform *) (** Transform *)
val map : t -> f:(t -> t) -> t val map : t -> f:(t -> t) -> t
val rename : Var.Subst.t -> t -> t val rename : Reg.Subst.t -> t -> t
(** Query *) (** Query *)
val fv : t -> Var.Set.t val fv : t -> Reg.Set.t
val is_true : t -> bool val is_true : t -> bool
val is_false : t -> bool val is_false : t -> bool
val typ : t -> Typ.t option val typ : t -> Typ.t option

@ -288,9 +288,10 @@ let xlate_float : Llvm.llvalue -> Exp.t =
let data = suffix_after_last_space (Llvm.string_of_llvalue llv) in let data = suffix_after_last_space (Llvm.string_of_llvalue llv) in
Exp.float data Exp.float data
let xlate_name ?global llv = Var.program ?global (find_name llv) let xlate_name ?global : Llvm.llvalue -> Reg.t =
fun llv -> Reg.program ?global (find_name llv)
let xlate_name_opt : Llvm.llvalue -> Var.t option = let xlate_name_opt : Llvm.llvalue -> Reg.t option =
fun instr -> fun instr ->
match Llvm.classify_type (Llvm.type_of instr) with match Llvm.classify_type (Llvm.type_of instr) with
| Void -> None | Void -> None
@ -357,11 +358,11 @@ and xlate_value ?(inline = false) : x -> Llvm.llvalue -> Exp.t =
let fname = Llvm.value_name func in let fname = Llvm.value_name func in
match xlate_intrinsic_exp fname with match xlate_intrinsic_exp fname with
| Some intrinsic when inline || should_inline llv -> intrinsic x llv | Some intrinsic when inline || should_inline llv -> intrinsic x llv
| _ -> Exp.var (xlate_name llv) ) | _ -> Exp.reg (xlate_name llv) )
| Instruction (Invoke | Alloca | Load | PHI | LandingPad | VAArg) | Instruction (Invoke | Alloca | Load | PHI | LandingPad | VAArg)
|Argument -> |Argument ->
Exp.var (xlate_name llv) Exp.reg (xlate_name llv)
| Function | GlobalVariable -> Exp.var (xlate_global x llv).var | Function | GlobalVariable -> Exp.reg (xlate_global x llv).reg
| GlobalAlias -> xlate_value x (Llvm.operand llv 0) | GlobalAlias -> xlate_value x (Llvm.operand llv 0)
| ConstantInt -> xlate_int x llv | ConstantInt -> xlate_int x llv
| ConstantFP -> xlate_float llv | ConstantFP -> xlate_float llv
@ -407,7 +408,7 @@ and xlate_value ?(inline = false) : x -> Llvm.llvalue -> Exp.t =
| Select | GetElementPtr | ExtractElement | InsertElement | Select | GetElementPtr | ExtractElement | InsertElement
| ShuffleVector | ExtractValue | InsertValue ) as opcode ) -> | ShuffleVector | ExtractValue | InsertValue ) as opcode ) ->
if inline || should_inline llv then xlate_opcode x llv opcode if inline || should_inline llv then xlate_opcode x llv opcode
else Exp.var (xlate_name llv) else Exp.reg (xlate_name llv)
| ConstantExpr -> xlate_opcode x llv (Llvm.constexpr_opcode llv) | ConstantExpr -> xlate_opcode x llv (Llvm.constexpr_opcode llv)
| GlobalIFunc -> todo "ifuncs: %a" pp_llvalue llv () | GlobalIFunc -> todo "ifuncs: %a" pp_llvalue llv ()
| Instruction (CatchPad | CleanupPad | CatchSwitch) -> | Instruction (CatchPad | CleanupPad | CatchSwitch) ->
@ -630,15 +631,15 @@ type pop_thunk = Loc.t -> Llair.inst list
let pop_stack_frame_of_function : let pop_stack_frame_of_function :
Llvm.llvalue -> Llvm.llbasicblock -> pop_thunk = Llvm.llvalue -> Llvm.llbasicblock -> pop_thunk =
fun func entry_blk -> fun func entry_blk ->
let append_stack_vars blk vars = let append_stack_regs blk regs =
Llvm.fold_right_instrs Llvm.fold_right_instrs
(fun instr vars -> (fun instr regs ->
match Llvm.instr_opcode instr with match Llvm.instr_opcode instr with
| Alloca -> xlate_name instr :: vars | Alloca -> xlate_name instr :: regs
| _ -> vars ) | _ -> regs )
blk vars blk regs
in in
let entry_vars = append_stack_vars entry_blk [] in let entry_regs = append_stack_regs entry_blk [] in
Llvm.iter_blocks Llvm.iter_blocks
(fun blk -> (fun blk ->
if not (Poly.equal entry_blk blk) then if not (Poly.equal entry_blk blk) then
@ -652,8 +653,8 @@ let pop_stack_frame_of_function :
blk ) blk )
func ; func ;
let pop retn_loc = let pop retn_loc =
List.map entry_vars ~f:(fun var -> List.map entry_regs ~f:(fun reg ->
Llair.Inst.free ~ptr:(Exp.var var) ~loc:retn_loc ) Llair.Inst.free ~ptr:(Exp.reg reg) ~loc:retn_loc )
in in
pop pop
@ -690,7 +691,7 @@ let landingpad_typs : x -> Llvm.llvalue -> Typ.t * Typ.t * Llvm.lltype =
the PHIs of [dst] translated to a move. *) the PHIs of [dst] translated to a move. *)
let xlate_jump : let xlate_jump :
x x
-> ?reg_exps:(Var.var * Exp.t) list -> ?reg_exps:(Reg.reg * Exp.t) list
-> Llvm.llvalue -> Llvm.llvalue
-> Llvm.llbasicblock -> Llvm.llbasicblock
-> Loc.t -> Loc.t
@ -753,7 +754,7 @@ let pp_code fs (insts, term, blocks) =
let rec xlate_func_name x llv = let rec xlate_func_name x llv =
match Llvm.classify_value llv with match Llvm.classify_value llv with
| Function -> Exp.var (xlate_name ~global:() llv) | Function -> Exp.reg (xlate_name ~global:() llv)
| ConstantExpr -> xlate_opcode x llv (Llvm.constexpr_opcode llv) | ConstantExpr -> xlate_opcode x llv (Llvm.constexpr_opcode llv)
| Argument | Instruction _ -> xlate_value x llv | Argument | Instruction _ -> xlate_value x llv
| GlobalAlias -> xlate_func_name x (Llvm.operand llv 0) | GlobalAlias -> xlate_func_name x (Llvm.operand llv 0)
@ -1076,8 +1077,8 @@ let xlate_instr :
passing a value for the selector which the handler code tests to passing a value for the selector which the handler code tests to
e.g. either cleanup or rethrow. *) e.g. either cleanup or rethrow. *)
let i32, tip, cxa_exception = landingpad_typs x instr in let i32, tip, cxa_exception = landingpad_typs x instr in
let exc = Exp.var (Var.program (find_name instr ^ ".exc")) in let exc = Exp.reg (Reg.program (find_name instr ^ ".exc")) in
let ti = Var.program (name ^ ".ti") in let ti = Reg.program (name ^ ".ti") in
(* std::type_info* ti = ((__cxa_exception* )exc - 1)->exceptionType *) (* std::type_info* ti = ((__cxa_exception* )exc - 1)->exceptionType *)
let load_ti = let load_ti =
let typ = cxa_exception in let typ = cxa_exception in
@ -1093,7 +1094,7 @@ let xlate_instr :
let len = Exp.integer (Z.of_int (size_of x typ)) Typ.siz in let len = Exp.integer (Z.of_int (size_of x typ)) Typ.siz in
Llair.Inst.load ~reg:ti ~ptr ~len ~loc Llair.Inst.load ~reg:ti ~ptr ~len ~loc
in in
let ti = Exp.var ti in let ti = Exp.reg ti in
let typeid = xlate_llvm_eh_typeid_for x tip ti in let typeid = xlate_llvm_eh_typeid_for x tip ti in
let lbl = name ^ ".unwind" in let lbl = name ^ ".unwind" in
let param = xlate_name instr in let param = xlate_name instr in
@ -1245,10 +1246,10 @@ let xlate_function : x -> Llvm.llvalue -> Llair.func =
let freturn = let freturn =
match name.typ with match name.typ with
| Pointer {elt= Function {return= Some _; _}} -> | Pointer {elt= Function {return= Some _; _}} ->
Some (Var.program "freturn") Some (Reg.program "freturn")
| _ -> None | _ -> None
in in
let fthrow = Var.program "fthrow" in let fthrow = Reg.program "fthrow" in
( match Llvm.block_begin llf with ( match Llvm.block_begin llf with
| Before entry_blk -> | Before entry_blk ->
let pop = pop_stack_frame_of_function llf entry_blk in let pop = pop_stack_frame_of_function llf entry_blk in

@ -7,27 +7,27 @@
(** Global variables *) (** Global variables *)
type t = {var: Var.t; init: (Exp.t * int) option; typ: Typ.t; loc: Loc.t} type t = {reg: Reg.t; init: (Exp.t * int) option; typ: Typ.t; loc: Loc.t}
[@@deriving compare, equal, hash, sexp] [@@deriving compare, equal, hash, sexp]
let pp fs {var} = let pp fs {reg} =
let name = Var.name var in let name = Reg.name reg in
let pf pp = let pf pp =
Format.pp_open_box fs 2 ; Format.pp_open_box fs 2 ;
Format.kfprintf (fun fs -> Format.pp_close_box fs ()) fs pp Format.kfprintf (fun fs -> Format.pp_close_box fs ()) fs pp
in in
pf "@%s%a" name Var.pp_demangled var pf "@%s%a" name Reg.pp_demangled reg
let pp_defn fs {var; init; typ; loc} = let pp_defn fs {reg; init; typ; loc} =
Format.fprintf fs "@[<2>%a %a%a%a@]" Typ.pp typ Var.pp var Loc.pp loc Format.fprintf fs "@[<2>%a %a%a%a@]" Typ.pp typ Reg.pp reg Loc.pp loc
(Option.pp "@ = @[%a@]" (fun fs (init, _) -> Exp.pp fs init)) (Option.pp "@ = @[%a@]" (fun fs (init, _) -> Exp.pp fs init))
init init
let invariant g = let invariant g =
Invariant.invariant [%here] g [%sexp_of: t] Invariant.invariant [%here] g [%sexp_of: t]
@@ fun () -> @@ fun () ->
let {var; typ} = g in let {reg; typ} = g in
assert (Typ.is_sized typ) ; assert (Typ.is_sized typ) ;
assert (Var.global var) assert (Reg.global reg)
let mk ?init var typ loc = {var; init; typ; loc} |> check invariant let mk ?init reg typ loc = {reg; init; typ; loc} |> check invariant

@ -8,7 +8,7 @@
(** Global variables *) (** Global variables *)
type t = private type t = private
{var: Var.t; init: (Exp.t * int) option; typ: Typ.t; loc: Loc.t} {reg: Reg.t; init: (Exp.t * int) option; typ: Typ.t; loc: Loc.t}
[@@deriving compare, equal, hash, sexp] [@@deriving compare, equal, hash, sexp]
val pp : t pp val pp : t pp
@ -16,4 +16,4 @@ val pp_defn : t pp
include Invariant.S with type t := t include Invariant.S with type t := t
val mk : ?init:Exp.t * int -> Var.t -> Typ.t -> Loc.t -> t val mk : ?init:Exp.t * int -> Reg.t -> Typ.t -> Loc.t -> t

@ -10,15 +10,15 @@
[@@@warning "+9"] [@@@warning "+9"]
type inst = type inst =
| Move of {reg_exps: (Var.t * Exp.t) vector; loc: Loc.t} | Move of {reg_exps: (Reg.t * Exp.t) vector; loc: Loc.t}
| Load of {reg: Var.t; ptr: Exp.t; len: Exp.t; loc: Loc.t} | Load of {reg: Reg.t; ptr: Exp.t; len: Exp.t; loc: Loc.t}
| Store of {ptr: Exp.t; exp: Exp.t; len: Exp.t; loc: Loc.t} | Store of {ptr: Exp.t; exp: Exp.t; len: Exp.t; loc: Loc.t}
| Memset of {dst: Exp.t; byt: Exp.t; len: Exp.t; loc: Loc.t} | Memset of {dst: Exp.t; byt: Exp.t; len: Exp.t; loc: Loc.t}
| Memcpy of {dst: Exp.t; src: Exp.t; len: Exp.t; loc: Loc.t} | Memcpy of {dst: Exp.t; src: Exp.t; len: Exp.t; loc: Loc.t}
| Memmov of {dst: Exp.t; src: Exp.t; len: Exp.t; loc: Loc.t} | Memmov of {dst: Exp.t; src: Exp.t; len: Exp.t; loc: Loc.t}
| Alloc of {reg: Var.t; num: Exp.t; len: Exp.t; loc: Loc.t} | Alloc of {reg: Reg.t; num: Exp.t; len: Exp.t; loc: Loc.t}
| Free of {ptr: Exp.t; loc: Loc.t} | Free of {ptr: Exp.t; loc: Loc.t}
| Nondet of {reg: Var.t option; msg: string; loc: Loc.t} | Nondet of {reg: Reg.t option; msg: string; loc: Loc.t}
| Abort of {loc: Loc.t} | Abort of {loc: Loc.t}
[@@deriving sexp] [@@deriving sexp]
@ -31,7 +31,7 @@ and 'a call =
{ callee: 'a { callee: 'a
; typ: Typ.t ; typ: Typ.t
; args: Exp.t list ; args: Exp.t list
; areturn: Var.t option ; areturn: Reg.t option
; return: jump ; return: jump
; throw: jump option ; throw: jump option
; mutable recursive: bool ; mutable recursive: bool
@ -57,10 +57,10 @@ and cfg = block vector
(* [entry] is not part of [cfg] since it cannot be jumped to, only called. *) (* [entry] is not part of [cfg] since it cannot be jumped to, only called. *)
and func = and func =
{ name: Global.t { name: Global.t
; params: Var.t list ; params: Reg.t list
; freturn: Var.t option ; freturn: Reg.t option
; fthrow: Var.t ; fthrow: Reg.t
; locals: Var.Set.t ; locals: Reg.Set.t
; entry: block ; entry: block
; cfg: cfg } ; cfg: cfg }
@ -87,7 +87,7 @@ let sexp_of_term = function
{ callee: Exp.t { callee: Exp.t
; typ: Typ.t ; typ: Typ.t
; args: Exp.t list ; args: Exp.t list
; areturn: Var.t option ; areturn: Reg.t option
; return: jump ; return: jump
; throw: jump option ; throw: jump option
; recursive: bool ; recursive: bool
@ -102,7 +102,7 @@ let sexp_of_block {lbl; cmnd; term; parent; sort_index} =
{ lbl: label { lbl: label
; cmnd: cmnd ; cmnd: cmnd
; term: term ; term: term
; parent: Var.t = parent.name.var ; parent: Reg.t = parent.name.reg
; sort_index: int }] ; sort_index: int }]
let sexp_of_cfg v = [%sexp_of: block vector] v let sexp_of_cfg v = [%sexp_of: block vector] v
@ -110,10 +110,10 @@ let sexp_of_cfg v = [%sexp_of: block vector] v
let sexp_of_func {name; params; freturn; fthrow; locals; entry; cfg} = let sexp_of_func {name; params; freturn; fthrow; locals; entry; cfg} =
[%sexp [%sexp
{ name: Global.t { name: Global.t
; params: Var.t list ; params: Reg.t list
; freturn: Var.t option ; freturn: Reg.t option
; fthrow: Var.t ; fthrow: Reg.t
; locals: Var.Set.t ; locals: Reg.Set.t
; entry: block ; entry: block
; cfg: cfg }] ; cfg: cfg }]
@ -131,10 +131,10 @@ let pp_inst fs inst =
match inst with match inst with
| Move {reg_exps; loc} -> | Move {reg_exps; loc} ->
let regs, exps = Vector.unzip reg_exps in let regs, exps = Vector.unzip reg_exps in
pf "@[<2>@[%a@]@ := @[%a@];@]\t%a" (Vector.pp ",@ " Var.pp) regs pf "@[<2>@[%a@]@ := @[%a@];@]\t%a" (Vector.pp ",@ " Reg.pp) regs
(Vector.pp ",@ " Exp.pp) exps Loc.pp loc (Vector.pp ",@ " Exp.pp) exps Loc.pp loc
| Load {reg; ptr; len; loc} -> | Load {reg; ptr; len; loc} ->
pf "@[<2>%a@ := load %a@ %a;@]\t%a" Var.pp reg Exp.pp len Exp.pp ptr pf "@[<2>%a@ := load %a@ %a;@]\t%a" Reg.pp reg Exp.pp len Exp.pp ptr
Loc.pp loc Loc.pp loc
| Store {ptr; exp; len; loc} -> | Store {ptr; exp; len; loc} ->
pf "@[<2>store %a@ %a@ %a;@]\t%a" Exp.pp len Exp.pp ptr Exp.pp exp pf "@[<2>store %a@ %a@ %a;@]\t%a" Exp.pp len Exp.pp ptr Exp.pp exp
@ -149,19 +149,19 @@ let pp_inst fs inst =
pf "@[<2>memmov %a %a %a;@]\t%a" Exp.pp len Exp.pp dst Exp.pp src pf "@[<2>memmov %a %a %a;@]\t%a" Exp.pp len Exp.pp dst Exp.pp src
Loc.pp loc Loc.pp loc
| Alloc {reg; num; len; loc} -> | Alloc {reg; num; len; loc} ->
pf "@[<2>%a@ := alloc [%a x %a];@]\t%a" Var.pp reg Exp.pp num Exp.pp pf "@[<2>%a@ := alloc [%a x %a];@]\t%a" Reg.pp reg Exp.pp num Exp.pp
len Loc.pp loc len Loc.pp loc
| Free {ptr; loc} -> pf "@[<2>free %a;@]\t%a" Exp.pp ptr Loc.pp loc | Free {ptr; loc} -> pf "@[<2>free %a;@]\t%a" Exp.pp ptr Loc.pp loc
| Nondet {reg; msg; loc} -> | Nondet {reg; msg; loc} ->
pf "@[<2>%anondet \"%s\";@]\t%a" pf "@[<2>%anondet \"%s\";@]\t%a"
(Option.pp "%a := " Var.pp) (Option.pp "%a := " Reg.pp)
reg msg Loc.pp loc reg msg Loc.pp loc
| Abort {loc} -> pf "@[<2>abort;@]\t%a" Loc.pp loc | Abort {loc} -> pf "@[<2>abort;@]\t%a" Loc.pp loc
let pp_args pp_arg fs args = let pp_args pp_arg fs args =
Format.fprintf fs "@ (@[%a@])" (List.pp ",@ " pp_arg) (List.rev args) Format.fprintf fs "@ (@[%a@])" (List.pp ",@ " pp_arg) (List.rev args)
let pp_param fs var = Var.pp fs var let pp_param fs reg = Reg.pp fs reg
let pp_jump fs {dst; retreating} = let pp_jump fs {dst; retreating} =
Format.fprintf fs "@[<2>%s%%%s@]" Format.fprintf fs "@[<2>%s%%%s@]"
@ -190,7 +190,7 @@ let pp_term fs term =
tbl Loc.pp loc tbl Loc.pp loc
| Call {callee; args; areturn; return; throw; recursive; loc; _} -> | Call {callee; args; areturn; return; throw; recursive; loc; _} ->
pf "@[<2>@[<7>%acall @[<2>%s%a%a@]@]@ @[returnto %a%a;@]@]\t%a" pf "@[<2>@[<7>%acall @[<2>%s%a%a@]@]@ @[returnto %a%a;@]@]\t%a"
(Option.pp "%a := " Var.pp) (Option.pp "%a := " Reg.pp)
areturn areturn
(if recursive then "" else "") (if recursive then "" else "")
Exp.pp callee (pp_args Exp.pp) args pp_jump return Exp.pp callee (pp_args Exp.pp) args pp_jump return
@ -219,13 +219,13 @@ let rec dummy_block =
; sort_index= 0 } ; sort_index= 0 }
and dummy_func = and dummy_func =
let dummy_var = Var.program ~global:() "dummy" in let dummy_reg = Reg.program ~global:() "dummy" in
let dummy_ptr_typ = Typ.pointer ~elt:(Typ.opaque ~name:"dummy") in let dummy_ptr_typ = Typ.pointer ~elt:(Typ.opaque ~name:"dummy") in
{ name= Global.mk dummy_var dummy_ptr_typ Loc.none { name= Global.mk dummy_reg dummy_ptr_typ Loc.none
; params= [] ; params= []
; freturn= None ; freturn= None
; fthrow= dummy_var ; fthrow= dummy_reg
; locals= Var.Set.empty ; locals= Reg.Set.empty
; entry= dummy_block ; entry= dummy_block
; cfg= Vector.empty } ; cfg= Vector.empty }
@ -270,7 +270,7 @@ module Inst = struct
|Abort _ -> |Abort _ ->
vs vs
let locals inst = union_locals inst Var.Set.empty let locals inst = union_locals inst Reg.Set.empty
let fold_exps inst ~init ~f = let fold_exps inst ~init ~f =
match inst with match inst with
@ -408,7 +408,7 @@ module Func = struct
( match name.typ with ( match name.typ with
| Pointer {elt= Function {return; _}} -> return | Pointer {elt= Function {return; _}} -> return
| _ -> None ) | _ -> None )
(Option.pp " %a := " Var.pp) (Option.pp " %a := " Reg.pp)
freturn Global.pp name (pp_args pp_param) params freturn Global.pp name (pp_args pp_param) params
(fun fs -> (fun fs ->
if is_undefined func then Format.fprintf fs " #%i@]" sort_index if is_undefined func then Format.fprintf fs " #%i@]" sort_index
@ -451,7 +451,7 @@ module Func = struct
let locals_block locals block = let locals_block locals block =
locals_cmnd (Term.union_locals block.term locals) block.cmnd locals_cmnd (Term.union_locals block.term locals) block.cmnd
in in
let init = locals_block Var.Set.empty entry in let init = locals_block Reg.Set.empty entry in
Vector.fold ~f:locals_block cfg ~init Vector.fold ~f:locals_block cfg ~init
in in
let func = {name; params; freturn; fthrow; locals; entry; cfg} in let func = {name; params; freturn; fthrow; locals; entry; cfg} in
@ -509,17 +509,17 @@ module Block_label = struct
end end
module BlockQ = Hash_queue.Make (Block_label) module BlockQ = Hash_queue.Make (Block_label)
module FuncQ = Hash_queue.Make (Var) module FuncQ = Hash_queue.Make (Reg)
let set_derived_metadata functions = let set_derived_metadata functions =
let compute_roots functions = let compute_roots functions =
let roots = FuncQ.create () in let roots = FuncQ.create () in
Map.iter functions ~f:(fun func -> Map.iter functions ~f:(fun func ->
FuncQ.enqueue_back_exn roots func.name.var func ) ; FuncQ.enqueue_back_exn roots func.name.reg func ) ;
Map.iter functions ~f:(fun func -> Map.iter functions ~f:(fun func ->
Func.fold_term func ~init:() ~f:(fun () -> function Func.fold_term func ~init:() ~f:(fun () -> function
| Call {callee; _} -> ( | Call {callee; _} -> (
match Var.of_exp callee with match Reg.of_exp callee with
| Some callee -> | Some callee ->
FuncQ.remove roots callee |> (ignore : [> ] -> unit) FuncQ.remove roots callee |> (ignore : [> ] -> unit)
| None -> () ) | None -> () )
@ -543,7 +543,7 @@ let set_derived_metadata functions =
| Iswitch {tbl; _} -> Vector.iter tbl ~f:jump | Iswitch {tbl; _} -> Vector.iter tbl ~f:jump
| Call ({callee; return; throw; _} as call) -> | Call ({callee; return; throw; _} as call) ->
( match ( match
Var.of_exp callee >>| Var.name >>= Func.find functions Reg.of_exp callee >>| Reg.name >>= Func.find functions
with with
| Some func -> | Some func ->
if Set.mem ancestors func.entry then call.recursive <- true if Set.mem ancestors func.entry then call.recursive <- true
@ -575,7 +575,7 @@ let set_derived_metadata functions =
List.fold functions List.fold functions
~init:(Map.empty (module String)) ~init:(Map.empty (module String))
~f:(fun m func -> ~f:(fun m func ->
Map.add_exn m ~key:(Var.name func.name.var) ~data:func ) Map.add_exn m ~key:(Reg.name func.name.reg) ~data:func )
in in
let roots = compute_roots functions in let roots = compute_roots functions in
let tips_to_roots = topsort functions roots in let tips_to_roots = topsort functions roots in
@ -589,7 +589,7 @@ let invariant pgm =
assert ( assert (
not not
(Vector.contains_dup pgm.globals ~compare:(fun g1 g2 -> (Vector.contains_dup pgm.globals ~compare:(fun g1 g2 ->
Var.compare g1.Global.var g2.Global.var )) ) Reg.compare g1.Global.reg g2.Global.reg )) )
let mk ~globals ~functions = let mk ~globals ~functions =
{ globals= Vector.of_list_rev globals { globals= Vector.of_list_rev globals

@ -10,10 +10,10 @@
(** Instructions for memory manipulation or other non-control effects. *) (** Instructions for memory manipulation or other non-control effects. *)
type inst = private type inst = private
| Move of {reg_exps: (Var.t * Exp.t) vector; loc: Loc.t} | Move of {reg_exps: (Reg.t * Exp.t) vector; loc: Loc.t}
(** Move each value [exp] into corresponding register [reg]. All of (** Move each value [exp] into corresponding register [reg]. All of
the moves take effect simultaneously. *) the moves take effect simultaneously. *)
| Load of {reg: Var.t; ptr: Exp.t; len: Exp.t; loc: Loc.t} | Load of {reg: Reg.t; ptr: Exp.t; len: Exp.t; loc: Loc.t}
(** Read a [len]-byte value from the contents of memory at address (** Read a [len]-byte value from the contents of memory at address
[ptr] into [reg]. *) [ptr] into [reg]. *)
| Store of {ptr: Exp.t; exp: Exp.t; len: Exp.t; loc: Loc.t} | Store of {ptr: Exp.t; exp: Exp.t; len: Exp.t; loc: Loc.t}
@ -25,12 +25,12 @@ type inst = private
if ranges overlap. *) if ranges overlap. *)
| Memmov of {dst: Exp.t; src: Exp.t; len: Exp.t; loc: Loc.t} | Memmov of {dst: Exp.t; src: Exp.t; len: Exp.t; loc: Loc.t}
(** Copy [len] bytes starting from address [src] to [dst]. *) (** Copy [len] bytes starting from address [src] to [dst]. *)
| Alloc of {reg: Var.t; num: Exp.t; len: Exp.t; loc: Loc.t} | Alloc of {reg: Reg.t; num: Exp.t; len: Exp.t; loc: Loc.t}
(** Allocate a block of memory large enough to store [num] elements of (** Allocate a block of memory large enough to store [num] elements of
[len] bytes each and bind [reg] to the first address. *) [len] bytes each and bind [reg] to the first address. *)
| Free of {ptr: Exp.t; loc: Loc.t} | Free of {ptr: Exp.t; loc: Loc.t}
(** Deallocate the previously allocated block at address [ptr]. *) (** Deallocate the previously allocated block at address [ptr]. *)
| Nondet of {reg: Var.t option; msg: string; loc: Loc.t} | Nondet of {reg: Reg.t option; msg: string; loc: Loc.t}
(** Bind [reg] to an arbitrary value, representing non-deterministic (** Bind [reg] to an arbitrary value, representing non-deterministic
approximation of behavior described by [msg]. *) approximation of behavior described by [msg]. *)
| Abort of {loc: Loc.t} (** Trigger abnormal program termination *) | Abort of {loc: Loc.t} (** Trigger abnormal program termination *)
@ -49,7 +49,7 @@ and 'a call =
{ callee: 'a { callee: 'a
; typ: Typ.t (** Type of the callee. *) ; typ: Typ.t (** Type of the callee. *)
; args: Exp.t list (** Stack of arguments, first-arg-last. *) ; args: Exp.t list (** Stack of arguments, first-arg-last. *)
; areturn: Var.t option (** Register to receive return value. *) ; areturn: Reg.t option (** Register to receive return value. *)
; return: jump (** Return destination. *) ; return: jump (** Return destination. *)
; throw: jump option (** Handler destination. *) ; throw: jump option (** Handler destination. *)
; mutable recursive: bool ; mutable recursive: bool
@ -89,10 +89,10 @@ and cfg
parameters are the function parameters. *) parameters are the function parameters. *)
and func = private and func = private
{ name: Global.t { name: Global.t
; params: Var.t list (** Formal parameters, first-param-last stack *) ; params: Reg.t list (** Formal parameters, first-param-last stack *)
; freturn: Var.t option ; freturn: Reg.t option
; fthrow: Var.t ; fthrow: Reg.t
; locals: Var.Set.t (** Local variables *) ; locals: Reg.Set.t (** Local registers *)
; entry: block ; entry: block
; cfg: cfg } ; cfg: cfg }
@ -112,18 +112,18 @@ module Inst : sig
type t = inst type t = inst
val pp : t pp val pp : t pp
val move : reg_exps:(Var.t * Exp.t) vector -> loc:Loc.t -> inst val move : reg_exps:(Reg.t * Exp.t) vector -> loc:Loc.t -> inst
val load : reg:Var.t -> ptr:Exp.t -> len:Exp.t -> loc:Loc.t -> inst val load : reg:Reg.t -> ptr:Exp.t -> len:Exp.t -> loc:Loc.t -> inst
val store : ptr:Exp.t -> exp:Exp.t -> len:Exp.t -> loc:Loc.t -> inst val store : ptr:Exp.t -> exp:Exp.t -> len:Exp.t -> loc:Loc.t -> inst
val memset : dst:Exp.t -> byt:Exp.t -> len:Exp.t -> loc:Loc.t -> inst val memset : dst:Exp.t -> byt:Exp.t -> len:Exp.t -> loc:Loc.t -> inst
val memcpy : dst:Exp.t -> src:Exp.t -> len:Exp.t -> loc:Loc.t -> inst val memcpy : dst:Exp.t -> src:Exp.t -> len:Exp.t -> loc:Loc.t -> inst
val memmov : dst:Exp.t -> src:Exp.t -> len:Exp.t -> loc:Loc.t -> inst val memmov : dst:Exp.t -> src:Exp.t -> len:Exp.t -> loc:Loc.t -> inst
val alloc : reg:Var.t -> num:Exp.t -> len:Exp.t -> loc:Loc.t -> inst val alloc : reg:Reg.t -> num:Exp.t -> len:Exp.t -> loc:Loc.t -> inst
val free : ptr:Exp.t -> loc:Loc.t -> inst val free : ptr:Exp.t -> loc:Loc.t -> inst
val nondet : reg:Var.t option -> msg:string -> loc:Loc.t -> inst val nondet : reg:Reg.t option -> msg:string -> loc:Loc.t -> inst
val abort : loc:Loc.t -> inst val abort : loc:Loc.t -> inst
val loc : inst -> Loc.t val loc : inst -> Loc.t
val locals : inst -> Var.Set.t val locals : inst -> Reg.Set.t
val fold_exps : inst -> init:'a -> f:('a -> Exp.t -> 'a) -> 'a val fold_exps : inst -> init:'a -> f:('a -> Exp.t -> 'a) -> 'a
end end
@ -154,7 +154,7 @@ module Term : sig
func:Exp.t func:Exp.t
-> typ:Typ.t -> typ:Typ.t
-> args:Exp.t list -> args:Exp.t list
-> areturn:Var.t option -> areturn:Reg.t option
-> return:jump -> return:jump
-> throw:jump option -> throw:jump option
-> loc:Loc.t -> loc:Loc.t
@ -184,18 +184,18 @@ module Func : sig
val mk : val mk :
name:Global.t name:Global.t
-> params:Var.t list -> params:Reg.t list
-> freturn:Var.t option -> freturn:Reg.t option
-> fthrow:Var.t -> fthrow:Reg.t
-> entry:block -> entry:block
-> cfg:block vector -> cfg:block vector
-> func -> func
val mk_undefined : val mk_undefined :
name:Global.t name:Global.t
-> params:Var.t list -> params:Reg.t list
-> freturn:Var.t option -> freturn:Reg.t option
-> fthrow:Var.t -> fthrow:Reg.t
-> t -> t
val find : functions -> string -> func option val find : functions -> string -> func option

@ -0,0 +1,10 @@
(*
* Copyright (c) Facebook, Inc. and its affiliates.
*
* This source code is licensed under the MIT license found in the
* LICENSE file in the root directory of this source tree.
*)
(** Variables *)
include Exp.Reg

@ -0,0 +1,10 @@
(*
* Copyright (c) Facebook, Inc. and its affiliates.
*
* This source code is licensed under the MIT license found in the
* LICENSE file in the root directory of this source tree.
*)
(** Variables *)
include module type of Exp.Reg

@ -16,8 +16,8 @@ let unknown_call call =
(fun fs (call : Llair.Term.t) -> (fun fs (call : Llair.Term.t) ->
match call with match call with
| Call {callee} -> ( | Call {callee} -> (
match Var.of_exp callee with match Reg.of_exp callee with
| Some var -> Var.pp_demangled fs var | Some reg -> Reg.pp_demangled fs reg
| None -> Exp.pp fs callee ) | None -> Exp.pp fs callee )
| _ -> () ) | _ -> () )
call Llair.Term.pp call] call Llair.Term.pp call]

@ -75,14 +75,14 @@ let used_globals pgm preanalyze =
{ bound= 1 { bound= 1
; skip_throw= false ; skip_throw= false
; function_summaries= true ; function_summaries= true
; globals= `Declared Var.Set.empty } ; globals= `Declared Reg.Set.empty }
pgm pgm
in in
`Per_function (Map.map summary_table ~f:Var.Set.union_list) `Per_function (Map.map summary_table ~f:Reg.Set.union_list)
else else
`Declared `Declared
(Vector.fold pgm.globals ~init:Var.Set.empty ~f:(fun acc g -> (Vector.fold pgm.globals ~init:Reg.Set.empty ~f:(fun acc g ->
Set.add acc g.var )) Set.add acc g.reg ))
let analyze = let analyze =
let%map_open bound = let%map_open bound =

@ -7,11 +7,11 @@
(** Equality over uninterpreted functions and linear rational arithmetic *) (** Equality over uninterpreted functions and linear rational arithmetic *)
type 'a exp_map = 'a Map.M(Exp).t [@@deriving compare, equal, sexp] type 'a term_map = 'a Map.M(Term).t [@@deriving compare, equal, sexp]
let empty_map = Map.empty (module Exp) let empty_map = Map.empty (module Term)
type subst = Exp.t exp_map [@@deriving compare, equal, sexp] type subst = Term.t term_map [@@deriving compare, equal, sexp]
(** see also [invariant] *) (** see also [invariant] *)
type t = type t =
@ -24,7 +24,7 @@ type t =
let classes r = let classes r =
Map.fold r.rep ~init:empty_map ~f:(fun ~key ~data cls -> Map.fold r.rep ~init:empty_map ~f:(fun ~key ~data cls ->
if Exp.equal key data then cls if Term.equal key data then cls
else Map.add_multi cls ~key:data ~data:key ) else Map.add_multi cls ~key:data ~data:key )
(** Pretty-printing *) (** Pretty-printing *)
@ -36,17 +36,17 @@ let pp fs {sat; rep} =
in in
Format.fprintf fs "[@[<hv>%a@]]" (List.pp ";@ " pp_assoc) alist Format.fprintf fs "[@[<hv>%a@]]" (List.pp ";@ " pp_assoc) alist
in in
let pp_exp_v fs (k, v) = if not (Exp.equal k v) then Exp.pp fs v in let pp_term_v fs (k, v) = if not (Term.equal k v) then Term.pp fs v in
Format.fprintf fs "@[{@[<hv>sat= %b;@ rep= %a@]}@]" sat Format.fprintf fs "@[{@[<hv>sat= %b;@ rep= %a@]}@]" sat
(pp_alist Exp.pp pp_exp_v) (pp_alist Term.pp pp_term_v)
(Map.to_alist rep) (Map.to_alist rep)
let pp_classes ?is_x fs r = let pp_classes ?is_x fs r =
List.pp "@ @<2>∧ " List.pp "@ @<2>∧ "
(fun fs (key, data) -> (fun fs (key, data) ->
Format.fprintf fs "@[%a@ = %a@]" (Exp.pp_full ?is_x) key Format.fprintf fs "@[%a@ = %a@]" (Term.pp_full ?is_x) key
(List.pp "@ = " (Exp.pp_full ?is_x)) (List.pp "@ = " (Term.pp_full ?is_x))
(List.sort ~compare:Exp.compare data) ) (List.sort ~compare:Term.compare data) )
fs fs
(Map.to_alist (classes r)) (Map.to_alist (classes r))
@ -66,17 +66,17 @@ let pp_diff fs (r, s) =
| k, `Unequal vv -> | k, `Unequal vv ->
Format.fprintf fs "[@[%a@ @<2>↦ %a@]]" pp_key k pp_sdiff_val vv Format.fprintf fs "[@[%a@ @<2>↦ %a@]]" pp_key k pp_sdiff_val vv
in in
let pp_sdiff_exp_map = let pp_sdiff_term_map =
let pp_sdiff_exp fs (u, v) = let pp_sdiff_term fs (u, v) =
Format.fprintf fs "-- %a ++ %a" Exp.pp u Exp.pp v Format.fprintf fs "-- %a ++ %a" Term.pp u Term.pp v
in in
pp_sdiff_map (pp_sdiff_elt Exp.pp Exp.pp pp_sdiff_exp) Exp.equal pp_sdiff_map (pp_sdiff_elt Term.pp Term.pp pp_sdiff_term) Term.equal
in in
let pp_sat fs = let pp_sat fs =
if not (Bool.equal r.sat s.sat) then if not (Bool.equal r.sat s.sat) then
Format.fprintf fs "sat= @[-- %b@ ++ %b@];@ " r.sat s.sat Format.fprintf fs "sat= @[-- %b@ ++ %b@];@ " r.sat s.sat
in in
let pp_rep fs = pp_sdiff_exp_map "rep" fs r.rep s.rep in let pp_rep fs = pp_sdiff_term_map "rep" fs r.rep s.rep in
Format.fprintf fs "@[{@[<hv>%t%t@]}@]" pp_sat pp_rep Format.fprintf fs "@[{@[<hv>%t%t@]}@]" pp_sat pp_rep
(** Invariant *) (** Invariant *)
@ -85,68 +85,68 @@ let pp_diff fs (r, s) =
let in_car r e = Map.mem r.rep e let in_car r e = Map.mem r.rep e
let rec iter_max_solvables e ~f = let rec iter_max_solvables e ~f =
match Exp.classify e with match Term.classify e with
| `Interpreted -> Exp.iter ~f:(iter_max_solvables ~f) e | `Interpreted -> Term.iter ~f:(iter_max_solvables ~f) e
| _ -> f e | _ -> f e
let invariant r = let invariant r =
Invariant.invariant [%here] r [%sexp_of: t] Invariant.invariant [%here] r [%sexp_of: t]
@@ fun () -> @@ fun () ->
Map.iteri r.rep ~f:(fun ~key:a ~data:_ -> Map.iteri r.rep ~f:(fun ~key:a ~data:_ ->
(* no interpreted exps in carrier *) (* no interpreted terms in carrier *)
assert (Poly.(Exp.classify a <> `Interpreted)) ; assert (Poly.(Term.classify a <> `Interpreted)) ;
(* carrier is closed under sub-expressions *) (* carrier is closed under subterms *)
iter_max_solvables a ~f:(fun b -> iter_max_solvables a ~f:(fun b ->
assert ( assert (
in_car r b in_car r b
|| Trace.fail "@[subexp %a of %a not in carrier of@ %a@]" Exp.pp || Trace.fail "@[subterm %a of %a not in carrier of@ %a@]"
b Exp.pp a pp r ) ) ) Term.pp b Term.pp a pp r ) ) )
(** Core operations *) (** Core operations *)
let true_ = {sat= true; rep= empty_map} |> check invariant let true_ = {sat= true; rep= empty_map} |> check invariant
(** apply a subst to an exp *) (** apply a subst to a term *)
let apply s a = try Map.find_exn s a with Caml.Not_found -> a let apply s a = try Map.find_exn s a with Caml.Not_found -> a
(** apply a subst to maximal non-interpreted subexps *) (** apply a subst to maximal non-interpreted subterms *)
let rec norm s a = let rec norm s a =
match Exp.classify a with match Term.classify a with
| `Interpreted -> Exp.map ~f:(norm s) a | `Interpreted -> Term.map ~f:(norm s) a
| `Simplified -> apply s (Exp.map ~f:(norm s) a) | `Simplified -> apply s (Term.map ~f:(norm s) a)
| `Atomic | `Uninterpreted -> apply s a | `Atomic | `Uninterpreted -> apply s a
(** exps are congruent if equal after normalizing subexps *) (** terms are congruent if equal after normalizing subterms *)
let congruent r a b = let congruent r a b =
Exp.equal (Exp.map ~f:(norm r.rep) a) (Exp.map ~f:(norm r.rep) b) Term.equal (Term.map ~f:(norm r.rep) a) (Term.map ~f:(norm r.rep) b)
(** [lookup r a] is [b'] if [a ~ b = b'] for some equation [b = b'] in rep *) (** [lookup r a] is [b'] if [a ~ b = b'] for some equation [b = b'] in rep *)
let lookup r a = let lookup r a =
With_return.with_return With_return.with_return
@@ fun {return} -> @@ fun {return} ->
(* congruent specialized to assume [a] canonized and [b] non-interpreted *) (* congruent specialized to assume [a] canonized and [b] non-interpreted *)
let semi_congruent r a b = Exp.equal a (Exp.map ~f:(apply r.rep) b) in let semi_congruent r a b = Term.equal a (Term.map ~f:(apply r.rep) b) in
Map.iteri r.rep ~f:(fun ~key ~data -> Map.iteri r.rep ~f:(fun ~key ~data ->
if semi_congruent r a key then return data ) ; if semi_congruent r a key then return data ) ;
a a
(** rewrite an exp into canonical form using rep and, for uninterpreted (** rewrite a term into canonical form using rep and, for uninterpreted
exps, congruence composed with rep *) terms, congruence composed with rep *)
let rec canon r a = let rec canon r a =
match Exp.classify a with match Term.classify a with
| `Interpreted -> Exp.map ~f:(canon r) a | `Interpreted -> Term.map ~f:(canon r) a
| `Simplified | `Uninterpreted -> lookup r (Exp.map ~f:(canon r) a) | `Simplified | `Uninterpreted -> lookup r (Term.map ~f:(canon r) a)
| `Atomic -> apply r.rep a | `Atomic -> apply r.rep a
(** add an exp to the carrier *) (** add a term to the carrier *)
let rec extend a r = let rec extend a r =
match Exp.classify a with match Term.classify a with
| `Interpreted | `Simplified -> Exp.fold ~f:extend a ~init:r | `Interpreted | `Simplified -> Term.fold ~f:extend a ~init:r
| `Uninterpreted -> | `Uninterpreted ->
Map.find_or_add r.rep a Map.find_or_add r.rep a
~if_found:(fun _ -> r) ~if_found:(fun _ -> r)
~default:a ~default:a
~if_added:(fun rep -> Exp.fold ~f:extend a ~init:{r with rep}) ~if_added:(fun rep -> Term.fold ~f:extend a ~init:{r with rep})
| `Atomic -> r | `Atomic -> r
let extend a r = extend a r |> check invariant let extend a r = extend a r |> check invariant
@ -155,15 +155,15 @@ let compose r s =
let rep = Map.map ~f:(norm s) r.rep in let rep = Map.map ~f:(norm s) r.rep in
let rep = let rep =
Map.merge_skewed rep s ~combine:(fun ~key v1 v2 -> Map.merge_skewed rep s ~combine:(fun ~key v1 v2 ->
if Exp.equal v1 v2 then v1 if Term.equal v1 v2 then v1
else fail "domains intersect: %a" Exp.pp key () ) else fail "domains intersect: %a" Term.pp key () )
in in
{r with rep} {r with rep}
let merge a b r = let merge a b r =
[%Trace.call fun {pf} -> pf "%a@ %a@ %a" Exp.pp a Exp.pp b pp r] [%Trace.call fun {pf} -> pf "%a@ %a@ %a" Term.pp a Term.pp b pp r]
; ;
( match Exp.solve a b with ( match Term.solve a b with
| Some s -> compose r s | Some s -> compose r s
| None -> {r with sat= false} ) | None -> {r with sat= false} )
|> |>
@ -171,15 +171,15 @@ let merge a b r =
pf "%a" pp_diff (r, r') ; pf "%a" pp_diff (r, r') ;
invariant r'] invariant r']
(** find an unproved equation between congruent exps *) (** find an unproved equation between congruent terms *)
let find_missing r = let find_missing r =
With_return.with_return With_return.with_return
@@ fun {return} -> @@ fun {return} ->
Map.iteri r.rep ~f:(fun ~key:a ~data:a' -> Map.iteri r.rep ~f:(fun ~key:a ~data:a' ->
Map.iteri r.rep ~f:(fun ~key:b ~data:b' -> Map.iteri r.rep ~f:(fun ~key:b ~data:b' ->
if if
Exp.compare a b < 0 Term.compare a b < 0
&& (not (Exp.equal a' b')) && (not (Term.equal a' b'))
&& congruent r a b && congruent r a b
then return (Some (a', b')) ) ) ; then return (Some (a', b')) ) ) ;
None None
@ -207,15 +207,15 @@ let and_eq a b r =
let b' = canon r b in let b' = canon r b in
let r = extend a' r in let r = extend a' r in
let r = extend b' r in let r = extend b' r in
if Exp.equal a' b' then r else close (merge a' b' r) if Term.equal a' b' then r else close (merge a' b' r)
(** Exposed interface *) (** Exposed interface *)
let is_true {sat; rep} = let is_true {sat; rep} =
sat && Map.for_alli rep ~f:(fun ~key:a ~data:a' -> Exp.equal a a') sat && Map.for_alli rep ~f:(fun ~key:a ~data:a' -> Term.equal a a')
let is_false {sat} = not sat let is_false {sat} = not sat
let entails_eq r d e = Exp.equal (canon r d) (canon r e) let entails_eq r d e = Term.equal (canon r d) (canon r e)
let entails r s = let entails r s =
Map.for_alli s.rep ~f:(fun ~key:e ~data:e' -> entails_eq r e e') Map.for_alli s.rep ~f:(fun ~key:e ~data:e' -> entails_eq r e e')
@ -227,15 +227,15 @@ let class_of r e =
e' :: Map.find_multi (classes r) e' e' :: Map.find_multi (classes r) e'
let difference r a b = let difference r a b =
[%Trace.call fun {pf} -> pf "%a@ %a@ %a" Exp.pp a Exp.pp b pp r] [%Trace.call fun {pf} -> pf "%a@ %a@ %a" Term.pp a Term.pp b pp r]
; ;
let a = canon r a in let a = canon r a in
let b = canon r b in let b = canon r b in
( if Exp.equal a b then Some Z.zero ( if Term.equal a b then Some Z.zero
else else
match (Exp.typ a, Exp.typ b) with match (Term.typ a, Term.typ b) with
| Some typ, _ | _, Some typ -> ( | Some typ, _ | _, Some typ -> (
match normalize r (Exp.sub typ a b) with match normalize r (Term.sub typ a b) with
| Integer {data} -> Some data | Integer {data} -> Some data
| _ -> None ) | _ -> None )
| _ -> None ) | _ -> None )
@ -265,17 +265,17 @@ let or_ r s =
let rs = merge_mems rs s r in let rs = merge_mems rs s r in
rs rs
(* assumes that f is injective and for any set of exps E, f[E] is disjoint (* assumes that f is injective and for any set of terms E, f[E] is disjoint
from E *) from E *)
let map_exps ({sat= _; rep} as r) ~f = let map_terms ({sat= _; rep} as r) ~f =
[%Trace.call fun {pf} -> pf "%a" pp r] [%Trace.call fun {pf} -> pf "%a" pp r]
; ;
let map m = let map m =
Map.fold m ~init:m ~f:(fun ~key ~data m -> Map.fold m ~init:m ~f:(fun ~key ~data m ->
let key' = f key in let key' = f key in
let data' = f data in let data' = f data in
if Exp.equal key' key then if Term.equal key' key then
if Exp.equal data' data then m else Map.set m ~key ~data:data' if Term.equal data' data then m else Map.set m ~key ~data:data'
else Map.remove m key |> Map.add_exn ~key:key' ~data:data' ) else Map.remove m key |> Map.add_exn ~key:key' ~data:data' )
in in
let rep' = map rep in let rep' = map rep in
@ -285,12 +285,12 @@ let map_exps ({sat= _; rep} as r) ~f =
pf "%a" pp_diff (r, r') ; pf "%a" pp_diff (r, r') ;
invariant r'] invariant r']
let rename r sub = map_exps r ~f:(Exp.rename sub) let rename r sub = map_terms r ~f:(Term.rename sub)
let fold_exps r ~init ~f = let fold_terms r ~init ~f =
Map.fold r.rep ~f:(fun ~key ~data z -> f (f z data) key) ~init Map.fold r.rep ~f:(fun ~key ~data z -> f (f z data) key) ~init
let fold_vars r ~init ~f = let fold_vars r ~init ~f =
fold_exps r ~init ~f:(fun init -> Exp.fold_vars ~f ~init) fold_terms r ~init ~f:(fun init -> Term.fold_vars ~f ~init)
let fv e = fold_vars e ~f:Set.add ~init:Var.Set.empty let fv e = fold_vars e ~f:Set.add ~init:Var.Set.empty

@ -11,14 +11,14 @@
type t [@@deriving compare, equal, sexp] type t [@@deriving compare, equal, sexp]
val pp : t pp val pp : t pp
val pp_classes : ?is_x:(Exp.t -> bool) -> t pp val pp_classes : ?is_x:(Term.t -> bool) -> t pp
include Invariant.S with type t := t include Invariant.S with type t := t
val true_ : t val true_ : t
(** The diagonal relation, which only equates each exp with itself. *) (** The diagonal relation, which only equates each term with itself. *)
val and_eq : Exp.t -> Exp.t -> t -> t val and_eq : Term.t -> Term.t -> t -> t
(** Conjoin an equation to a relation. *) (** Conjoin an equation to a relation. *)
val and_ : t -> t -> t val and_ : t -> t -> t
@ -31,7 +31,7 @@ val rename : t -> Var.Subst.t -> t
(** Apply a renaming substitution to the relation. *) (** Apply a renaming substitution to the relation. *)
val fv : t -> Var.Set.t val fv : t -> Var.Set.t
(** The variables occurring in the exps of the relation. *) (** The variables occurring in the terms of the relation. *)
val is_true : t -> bool val is_true : t -> bool
(** Test if the relation is diagonal. *) (** Test if the relation is diagonal. *)
@ -39,24 +39,24 @@ val is_true : t -> bool
val is_false : t -> bool val is_false : t -> bool
(** Test if the relation is empty / inconsistent. *) (** Test if the relation is empty / inconsistent. *)
val entails_eq : t -> Exp.t -> Exp.t -> bool val entails_eq : t -> Term.t -> Term.t -> bool
(** Test if an equation is entailed by a relation. *) (** Test if an equation is entailed by a relation. *)
val entails : t -> t -> bool val entails : t -> t -> bool
(** Test if one relation entails another. *) (** Test if one relation entails another. *)
val class_of : t -> Exp.t -> Exp.t list val class_of : t -> Term.t -> Term.t list
(** Equivalence class of [e]: all the expressions in [f] in the relation (** Equivalence class of [e]: all the terms [f] in the relation such that [e
such that [e = f] is implied by the relation. *) = f] is implied by the relation. *)
val normalize : t -> Exp.t -> Exp.t val normalize : t -> Term.t -> Term.t
(** Normalize an exp [e] to [e'] such that [e = e'] is implied by the (** Normalize a term [e] to [e'] such that [e = e'] is implied by the
relation, where [e'] and its sub-exps are expressed in terms of the relation, where [e'] and its subterms are expressed in terms of the
relation's canonical representatives of each equivalence class. *) relation's canonical representatives of each equivalence class. *)
val difference : t -> Exp.t -> Exp.t -> Z.t option val difference : t -> Term.t -> Term.t -> Z.t option
(** The difference as an offset. [difference r a b = Some k] if [r] implies (** The difference as an offset. [difference r a b = Some k] if [r] implies
[a = b+k], or [None] if [a] and [b] are not equal up to an integer [a = b+k], or [None] if [a] and [b] are not equal up to an integer
offset. *) offset. *)
val fold_exps : t -> init:'a -> f:('a -> Exp.t -> 'a) -> 'a val fold_terms : t -> init:'a -> f:('a -> Term.t -> 'a) -> 'a

@ -18,12 +18,12 @@ let%test_module _ =
let of_eqs = List.fold ~init:true_ ~f:(fun r (a, b) -> and_eq a b r) let of_eqs = List.fold ~init:true_ ~f:(fun r (a, b) -> and_eq a b r)
let i8 = Typ.integer ~bits:8 let i8 = Typ.integer ~bits:8
let i64 = Typ.integer ~bits:64 let i64 = Typ.integer ~bits:64
let ( ! ) i = Exp.integer (Z.of_int i) Typ.siz let ( ! ) i = Term.integer (Z.of_int i) Typ.siz
let ( + ) = Exp.add Typ.siz let ( + ) = Term.add Typ.siz
let ( - ) = Exp.sub Typ.siz let ( - ) = Term.sub Typ.siz
let ( * ) = Exp.mul Typ.siz let ( * ) = Term.mul Typ.siz
let f = Exp.convert ~dst:i64 ~src:i8 let f = Term.convert ~dst:i64 ~src:i8
let g = Exp.rem let g = Term.rem
let wrt = Var.Set.empty let wrt = Var.Set.empty
let t_, wrt = Var.fresh "t" ~wrt let t_, wrt = Var.fresh "t" ~wrt
let u_, wrt = Var.fresh "u" ~wrt let u_, wrt = Var.fresh "u" ~wrt
@ -32,13 +32,13 @@ let%test_module _ =
let x_, wrt = Var.fresh "x" ~wrt let x_, wrt = Var.fresh "x" ~wrt
let y_, wrt = Var.fresh "y" ~wrt let y_, wrt = Var.fresh "y" ~wrt
let z_, _ = Var.fresh "z" ~wrt let z_, _ = Var.fresh "z" ~wrt
let t = Exp.var t_ let t = Term.var t_
let u = Exp.var u_ let u = Term.var u_
let v = Exp.var v_ let v = Term.var v_
let w = Exp.var w_ let w = Term.var w_
let x = Exp.var x_ let x = Term.var x_
let y = Exp.var y_ let y = Term.var y_
let z = Exp.var z_ let z = Term.var z_
let f1 = of_eqs [(!0, !1)] let f1 = of_eqs [(!0, !1)]
let%test _ = is_false f1 let%test _ = is_false f1
@ -212,9 +212,9 @@ let%test_module _ =
%v_3 = %w_4 = %x_5 = %y_6 = %z_7 |}] %v_3 = %w_4 = %x_5 = %y_6 = %z_7 |}]
let%expect_test _ = let%expect_test _ =
printf (List.pp " , " Exp.pp) (Equality.class_of r7 t) ; printf (List.pp " , " Term.pp) (Equality.class_of r7 t) ;
printf (List.pp " , " Exp.pp) (Equality.class_of r7 x) ; printf (List.pp " , " Term.pp) (Equality.class_of r7 x) ;
printf (List.pp " , " Exp.pp) (Equality.class_of r7 z) ; printf (List.pp " , " Term.pp) (Equality.class_of r7 z) ;
[%expect [%expect
{| {|
%t_1 %t_1
@ -235,7 +235,7 @@ let%test_module _ =
{sat= true; {sat= true;
rep= [[%w_4 %v_3]; [%x_5 %v_3]; [%y_6 %v_3]; [%z_7 %v_3]]} |}] rep= [[%w_4 %v_3]; [%x_5 %v_3]; [%y_6 %v_3]; [%z_7 %v_3]]} |}]
let%test _ = normalize r7' w |> Exp.equal v let%test _ = normalize r7' w |> Term.equal v
let%test _ = let%test _ =
entails_eq (of_eqs [(g w x, g y z); (x, z)]) (g w x) (g w z) entails_eq (of_eqs [(g w x, g y z); (x, z)]) (g w x) (g w z)
@ -275,10 +275,10 @@ let%test_module _ =
let%expect_test _ = let%expect_test _ =
pp_classes r10 ; pp_classes r10 ;
pp r10 ; pp r10 ;
Format.printf "@.%a@." Exp.pp (z - (x + !8)) ; Format.printf "@.%a@." Term.pp (z - (x + !8)) ;
Format.printf "@.%a@." Exp.pp (normalize r10 (z - (x + !8))) ; Format.printf "@.%a@." Term.pp (normalize r10 (z - (x + !8))) ;
Format.printf "@.%a@." Exp.pp (x + !8 - z) ; Format.printf "@.%a@." Term.pp (x + !8 - z) ;
Format.printf "@.%a@." Exp.pp (normalize r10 (x + !8 - z)) ; Format.printf "@.%a@." Term.pp (normalize r10 (x + !8 - z)) ;
[%expect [%expect
{| {|
(%z_7 + -16) = %x_5 (%z_7 + -16) = %x_5
@ -308,7 +308,7 @@ let%test_module _ =
let%expect_test _ = pp_classes r12 ; [%expect {| (%z_7 + -16) = %x_5 |}] let%expect_test _ = pp_classes r12 ; [%expect {| (%z_7 + -16) = %x_5 |}]
let r13 = of_eqs [(Exp.eq x !2, y); (Exp.dq x !2, z); (y, z)] let r13 = of_eqs [(Term.eq x !2, y); (Term.dq x !2, z); (y, z)]
let%expect_test _ = let%expect_test _ =
pp r13 ; pp r13 ;
@ -319,15 +319,15 @@ let%test_module _ =
let%test _ = not (is_false r13) (* incomplete *) let%test _ = not (is_false r13) (* incomplete *)
let a = Exp.dq x !0 let a = Term.dq x !0
let r14 = of_eqs [(a, a); (x, !1)] let r14 = of_eqs [(a, a); (x, !1)]
let%expect_test _ = let%expect_test _ =
pp r14 ; [%expect {| {sat= true; rep= [[%x_5 1]]} |}] pp r14 ; [%expect {| {sat= true; rep= [[%x_5 1]]} |}]
let%test _ = entails_eq r14 a (Exp.bool true) let%test _ = entails_eq r14 a (Term.bool true)
let b = Exp.dq y !0 let b = Term.dq y !0
let r14 = of_eqs [(a, b); (x, !1)] let r14 = of_eqs [(a, b); (x, !1)]
let%expect_test _ = let%expect_test _ =
@ -336,10 +336,10 @@ let%test_module _ =
{| {|
{sat= true; rep= [[%x_5 1]; [(%y_6 0) -1]]} |}] {sat= true; rep= [[%x_5 1]; [(%y_6 0) -1]]} |}]
let%test _ = entails_eq r14 a (Exp.bool true) let%test _ = entails_eq r14 a (Term.bool true)
let%test _ = entails_eq r14 b (Exp.bool true) let%test _ = entails_eq r14 b (Term.bool true)
let b = Exp.convert ~dst:i64 ~src:i8 (Exp.dq x !0) let b = Term.convert ~dst:i64 ~src:i8 (Term.dq x !0)
let r15 = of_eqs [(b, b); (x, !1)] let r15 = of_eqs [(b, b); (x, !1)]
let%expect_test _ = let%expect_test _ =

@ -17,11 +17,13 @@ type xseg = {us: Var.Set.t; xs: Var.Set.t; seg: Sh.seg}
let fresh_var nam us xs = let fresh_var nam us xs =
let var, us = Var.fresh nam ~wrt:us in let var, us = Var.fresh nam ~wrt:us in
(Exp.var var, us, Set.add xs var) (Term.var var, us, Set.add xs var)
let fresh_seg ~loc ?bas ?len ?siz ?arr ?(xs = Var.Set.empty) us = let fresh_seg ~loc ?bas ?len ?siz ?arr ?(xs = Var.Set.empty) us =
let freshen exp nam us xs = let freshen term nam us xs =
match exp with Some exp -> (exp, us, xs) | None -> fresh_var nam us xs match term with
| Some term -> (term, us, xs)
| None -> fresh_var nam us xs
in in
let bas, us, xs = freshen bas "b" us xs in let bas, us, xs = freshen bas "b" us xs in
let len, us, xs = freshen len "m" us xs in let len, us, xs = freshen len "m" us xs in
@ -29,8 +31,8 @@ let fresh_seg ~loc ?bas ?len ?siz ?arr ?(xs = Var.Set.empty) us =
let arr, us, xs = freshen arr "a" us xs in let arr, us, xs = freshen arr "a" us xs in
{us; xs; seg= {loc; bas; len; siz; arr}} {us; xs; seg= {loc; bas; len; siz; arr}}
let null_eq ptr = Sh.pure (Exp.eq Exp.null ptr) let null_eq ptr = Sh.pure (Term.eq Term.null ptr)
let zero = Exp.integer Z.zero Typ.siz let zero = Term.integer Z.zero Typ.siz
(* Overwritten variables renaming and remaining modified variables. [ws] are (* Overwritten variables renaming and remaining modified variables. [ws] are
the written variables; [rs] are the variables read or in the the written variables; [rs] are the variables read or in the
@ -63,12 +65,12 @@ let move_spec us reg_exps =
let ws, rs = let ws, rs =
Vector.fold reg_exps ~init:(Var.Set.empty, Var.Set.empty) Vector.fold reg_exps ~init:(Var.Set.empty, Var.Set.empty)
~f:(fun (ws, rs) (reg, exp) -> ~f:(fun (ws, rs) (reg, exp) ->
(Set.add ws reg, Set.union rs (Exp.fv exp)) ) (Set.add ws reg, Set.union rs (Term.fv exp)) )
in in
let sub, ms, _ = assign ~ws ~rs ~us in let sub, ms, _ = assign ~ws ~rs ~us in
let post = let post =
Vector.fold reg_exps ~init:Sh.emp ~f:(fun post (reg, exp) -> Vector.fold reg_exps ~init:Sh.emp ~f:(fun post (reg, exp) ->
Sh.and_ (Exp.eq (Exp.var reg) (Exp.rename sub exp)) post ) Sh.and_ (Term.eq (Term.var reg) (Term.rename sub exp)) post )
in in
{xs; foot; sub; ms; post} {xs; foot; sub; ms; post}
@ -82,7 +84,7 @@ let load_spec us reg ptr len =
let sub, ms, _ = assign ~ws:(Set.add Var.Set.empty reg) ~rs:foot.us ~us in let sub, ms, _ = assign ~ws:(Set.add Var.Set.empty reg) ~rs:foot.us ~us in
let post = let post =
Sh.and_ Sh.and_
(Exp.eq (Exp.var reg) (Exp.rename sub seg.arr)) (Term.eq (Term.var reg) (Term.rename sub seg.arr))
(Sh.rename sub foot) (Sh.rename sub foot)
in in
{xs; foot; sub; ms; post} {xs; foot; sub; ms; post}
@ -104,7 +106,7 @@ let store_spec us ptr exp len =
let memset_spec us dst byt len = let memset_spec us dst byt len =
let {us= _; xs; seg} = fresh_seg ~loc:dst ~siz:len us in let {us= _; xs; seg} = fresh_seg ~loc:dst ~siz:len us in
let foot = Sh.seg seg in let foot = Sh.seg seg in
let post = Sh.seg {seg with arr= Exp.splat ~byt ~siz:len} in let post = Sh.seg {seg with arr= Term.splat ~byt ~siz:len} in
{xs; foot; sub= Var.Subst.empty; ms= Var.Set.empty; post} {xs; foot; sub= Var.Subst.empty; ms= Var.Set.empty; post}
(* { d=s * l=0 * d-[b;m)->⟨l,α⟩ } (* { d=s * l=0 * d-[b;m)->⟨l,α⟩ }
@ -115,7 +117,7 @@ let memcpy_eq_spec us dst src len =
let {us= _; xs; seg} = fresh_seg ~loc:dst ~len us in let {us= _; xs; seg} = fresh_seg ~loc:dst ~len us in
let dst_heap = Sh.seg seg in let dst_heap = Sh.seg seg in
let foot = let foot =
Sh.and_ (Exp.eq dst src) (Sh.and_ (Exp.eq len zero) dst_heap) Sh.and_ (Term.eq dst src) (Sh.and_ (Term.eq len zero) dst_heap)
in in
let post = dst_heap in let post = dst_heap in
{xs; foot; sub= Var.Subst.empty; ms= Var.Set.empty; post} {xs; foot; sub= Var.Subst.empty; ms= Var.Set.empty; post}
@ -145,7 +147,7 @@ let memcpy_specs us dst src len =
let memmov_eq_spec us dst src len = let memmov_eq_spec us dst src len =
let {us= _; xs; seg= dst_seg} = fresh_seg ~loc:dst ~len us in let {us= _; xs; seg= dst_seg} = fresh_seg ~loc:dst ~len us in
let dst_heap = Sh.seg dst_seg in let dst_heap = Sh.seg dst_seg in
let foot = Sh.and_ (Exp.eq dst src) dst_heap in let foot = Sh.and_ (Term.eq dst src) dst_heap in
let post = dst_heap in let post = dst_heap in
{xs; foot; sub= Var.Subst.empty; ms= Var.Set.empty; post} {xs; foot; sub= Var.Subst.empty; ms= Var.Set.empty; post}
@ -163,17 +165,17 @@ let memmov_foot us dst src len =
let arr_dst, us, xs = fresh_var "a" us xs in let arr_dst, us, xs = fresh_var "a" us xs in
let arr_mid, us, xs = fresh_var "a" us xs in let arr_mid, us, xs = fresh_var "a" us xs in
let arr_src, us, xs = fresh_var "a" us xs in let arr_src, us, xs = fresh_var "a" us xs in
let src_dst = Exp.sub Typ.siz src dst in let src_dst = Term.sub Typ.siz src dst in
let mem_dst = Exp.memory ~siz:src_dst ~arr:arr_dst in let mem_dst = Term.memory ~siz:src_dst ~arr:arr_dst in
let siz_mid = Exp.sub Typ.siz len src_dst in let siz_mid = Term.sub Typ.siz len src_dst in
let mem_mid = Exp.memory ~siz:siz_mid ~arr:arr_mid in let mem_mid = Term.memory ~siz:siz_mid ~arr:arr_mid in
let mem_src = Exp.memory ~siz:src_dst ~arr:arr_src in let mem_src = Term.memory ~siz:src_dst ~arr:arr_src in
let mem_dst_mid_src = Exp.concat [|mem_dst; mem_mid; mem_src|] in let mem_dst_mid_src = Term.concat [|mem_dst; mem_mid; mem_src|] in
let siz_dst_mid_src, us, xs = fresh_var "m" us xs in let siz_dst_mid_src, us, xs = fresh_var "m" us xs in
let arr_dst_mid_src, _, xs = fresh_var "a" us xs in let arr_dst_mid_src, _, xs = fresh_var "a" us xs in
let eq_mem_dst_mid_src = let eq_mem_dst_mid_src =
Exp.eq mem_dst_mid_src Term.eq mem_dst_mid_src
(Exp.memory ~siz:siz_dst_mid_src ~arr:arr_dst_mid_src) (Term.memory ~siz:siz_dst_mid_src ~arr:arr_dst_mid_src)
in in
let seg = let seg =
Sh.seg Sh.seg
@ -181,8 +183,8 @@ let memmov_foot us dst src len =
in in
let foot = let foot =
Sh.and_ eq_mem_dst_mid_src Sh.and_ eq_mem_dst_mid_src
(Sh.and_ (Exp.lt dst src) (Sh.and_ (Term.lt dst src)
(Sh.and_ (Exp.lt src (Exp.add Typ.ptr dst len)) seg)) (Sh.and_ (Term.lt src (Term.add Typ.ptr dst len)) seg))
in in
(xs, bas, siz, mem_dst, mem_mid, mem_src, foot) (xs, bas, siz, mem_dst, mem_mid, mem_src, foot)
@ -194,12 +196,12 @@ let memmov_dn_spec us dst src len =
let xs, bas, siz, _, mem_mid, mem_src, foot = let xs, bas, siz, _, mem_mid, mem_src, foot =
memmov_foot us dst src len memmov_foot us dst src len
in in
let mem_mid_src_src = Exp.concat [|mem_mid; mem_src; mem_src|] in let mem_mid_src_src = Term.concat [|mem_mid; mem_src; mem_src|] in
let siz_mid_src_src, us, xs = fresh_var "m" us xs in let siz_mid_src_src, us, xs = fresh_var "m" us xs in
let arr_mid_src_src, _, xs = fresh_var "a" us xs in let arr_mid_src_src, _, xs = fresh_var "a" us xs in
let eq_mem_mid_src_src = let eq_mem_mid_src_src =
Exp.eq mem_mid_src_src Term.eq mem_mid_src_src
(Exp.memory ~siz:siz_mid_src_src ~arr:arr_mid_src_src) (Term.memory ~siz:siz_mid_src_src ~arr:arr_mid_src_src)
in in
let post = let post =
Sh.and_ eq_mem_mid_src_src Sh.and_ eq_mem_mid_src_src
@ -220,12 +222,12 @@ let memmov_up_spec us dst src len =
let xs, bas, siz, mem_src, mem_mid, _, foot = let xs, bas, siz, mem_src, mem_mid, _, foot =
memmov_foot us src dst len memmov_foot us src dst len
in in
let mem_src_src_mid = Exp.concat [|mem_src; mem_src; mem_mid|] in let mem_src_src_mid = Term.concat [|mem_src; mem_src; mem_mid|] in
let siz_src_src_mid, us, xs = fresh_var "m" us xs in let siz_src_src_mid, us, xs = fresh_var "m" us xs in
let arr_src_src_mid, _, xs = fresh_var "a" us xs in let arr_src_src_mid, _, xs = fresh_var "a" us xs in
let eq_mem_src_src_mid = let eq_mem_src_src_mid =
Exp.eq mem_src_src_mid Term.eq mem_src_src_mid
(Exp.memory ~siz:siz_src_src_mid ~arr:arr_src_src_mid) (Term.memory ~siz:siz_src_src_mid ~arr:arr_src_src_mid)
in in
let post = let post =
Sh.and_ eq_mem_src_src_mid Sh.and_ eq_mem_src_src_mid
@ -250,12 +252,12 @@ let memmov_specs us dst src len =
*) *)
let alloc_spec us reg num len = let alloc_spec us reg num len =
let foot = Sh.emp in let foot = Sh.emp in
let siz = Exp.mul Typ.siz num len in let siz = Term.mul Typ.siz num len in
let sub, ms, us = let sub, ms, us =
assign ~ws:(Set.add Var.Set.empty reg) ~rs:(Exp.fv siz) ~us assign ~ws:(Set.add Var.Set.empty reg) ~rs:(Term.fv siz) ~us
in in
let loc = Exp.var reg in let loc = Term.var reg in
let siz = Exp.rename sub siz in let siz = Term.rename sub siz in
let {us= _; xs; seg} = fresh_seg ~loc ~bas:loc ~len:siz ~siz us in let {us= _; xs; seg} = fresh_seg ~loc ~bas:loc ~len:siz ~siz us in
let post = Sh.seg seg in let post = Sh.seg seg in
{xs; foot; sub; ms; post} {xs; foot; sub; ms; post}
@ -293,12 +295,12 @@ let dallocx_spec us ptr =
let malloc_spec us reg siz = let malloc_spec us reg siz =
let foot = Sh.emp in let foot = Sh.emp in
let sub, ms, us = let sub, ms, us =
assign ~ws:(Set.add Var.Set.empty reg) ~rs:(Exp.fv siz) ~us assign ~ws:(Set.add Var.Set.empty reg) ~rs:(Term.fv siz) ~us
in in
let loc = Exp.var reg in let loc = Term.var reg in
let siz = Exp.rename sub siz in let siz = Term.rename sub siz in
let {us= _; xs; seg} = fresh_seg ~loc ~bas:loc ~len:siz ~siz us in let {us= _; xs; seg} = fresh_seg ~loc ~bas:loc ~len:siz ~siz us in
let post = Sh.or_ (null_eq (Exp.var reg)) (Sh.seg seg) in let post = Sh.or_ (null_eq (Term.var reg)) (Sh.seg seg) in
{xs; foot; sub; ms; post} {xs; foot; sub; ms; post}
(* { s≠0 } (* { s≠0 }
@ -306,14 +308,14 @@ let malloc_spec us reg siz =
* { r=0 α'. r-[r;sΘ)->sΘ,α' } * { r=0 α'. r-[r;sΘ)->sΘ,α' }
*) *)
let mallocx_spec us reg siz = let mallocx_spec us reg siz =
let foot = Sh.pure Exp.(dq siz zero) in let foot = Sh.pure Term.(dq siz zero) in
let sub, ms, us = let sub, ms, us =
assign ~ws:(Set.add Var.Set.empty reg) ~rs:(Exp.fv siz) ~us assign ~ws:(Set.add Var.Set.empty reg) ~rs:(Term.fv siz) ~us
in in
let loc = Exp.var reg in let loc = Term.var reg in
let siz = Exp.rename sub siz in let siz = Term.rename sub siz in
let {us= _; xs; seg} = fresh_seg ~loc ~bas:loc ~len:siz ~siz us in let {us= _; xs; seg} = fresh_seg ~loc ~bas:loc ~len:siz ~siz us in
let post = Sh.or_ (null_eq (Exp.var reg)) (Sh.seg seg) in let post = Sh.or_ (null_eq (Term.var reg)) (Sh.seg seg) in
{xs; foot; sub; ms; post} {xs; foot; sub; ms; post}
(* { emp } (* { emp }
@ -322,18 +324,18 @@ let mallocx_spec us reg siz =
*) *)
let calloc_spec us reg num len = let calloc_spec us reg num len =
let foot = Sh.emp in let foot = Sh.emp in
let siz = Exp.mul Typ.siz num len in let siz = Term.mul Typ.siz num len in
let sub, ms, us = let sub, ms, us =
assign ~ws:(Set.add Var.Set.empty reg) ~rs:(Exp.fv siz) ~us assign ~ws:(Set.add Var.Set.empty reg) ~rs:(Term.fv siz) ~us
in in
let loc = Exp.var reg in let loc = Term.var reg in
let siz = Exp.rename sub siz in let siz = Term.rename sub siz in
let arr = Exp.splat ~byt:(Exp.integer Z.zero Typ.byt) ~siz in let arr = Term.splat ~byt:(Term.integer Z.zero Typ.byt) ~siz in
let {us= _; xs; seg} = fresh_seg ~loc ~bas:loc ~len:siz ~siz ~arr us in let {us= _; xs; seg} = fresh_seg ~loc ~bas:loc ~len:siz ~siz ~arr us in
let post = Sh.or_ (null_eq (Exp.var reg)) (Sh.seg seg) in let post = Sh.or_ (null_eq (Term.var reg)) (Sh.seg seg) in
{xs; foot; sub; ms; post} {xs; foot; sub; ms; post}
let size_of_ptr = Option.value_exn (Exp.size_of Typ.ptr) let size_of_ptr = Option.value_exn (Term.size_of Typ.ptr)
(* { p-[_;_)->⟨W,_⟩ } (* { p-[_;_)->⟨W,_⟩ }
* posix_memalign r p s * posix_memalign r p s
@ -347,7 +349,7 @@ let posix_memalign_spec us reg ptr siz =
let sub, ms, us = let sub, ms, us =
assign assign
~ws:(Set.add Var.Set.empty reg) ~ws:(Set.add Var.Set.empty reg)
~rs:(Set.union foot.us (Exp.fv siz)) ~rs:(Set.union foot.us (Term.fv siz))
~us ~us
in in
let q, us, xs = fresh_var "q" us xs in let q, us, xs = fresh_var "q" us xs in
@ -355,13 +357,13 @@ let posix_memalign_spec us reg ptr siz =
let {us= _; xs; seg= qseg} = let {us= _; xs; seg= qseg} =
fresh_seg ~loc:q ~bas:q ~len:siz ~siz ~xs us fresh_seg ~loc:q ~bas:q ~len:siz ~siz ~xs us
in in
let eok = Exp.integer (Z.of_int 0) Typ.int in let eok = Term.integer (Z.of_int 0) Typ.int in
let enomem = Exp.integer (Z.of_int 12) Typ.int in let enomem = Term.integer (Z.of_int 12) Typ.int in
let post = let post =
Sh.or_ Sh.or_
(Sh.and_ (Exp.eq (Exp.var reg) enomem) (Sh.rename sub foot)) (Sh.and_ (Term.eq (Term.var reg) enomem) (Sh.rename sub foot))
(Sh.and_ (Sh.and_
(Exp.eq (Exp.var reg) eok) (Term.eq (Term.var reg) eok)
(Sh.rename sub (Sh.star (Sh.seg pseg') (Sh.seg qseg)))) (Sh.rename sub (Sh.star (Sh.seg pseg') (Sh.seg qseg))))
in in
{xs; foot; sub; ms; post} {xs; foot; sub; ms; post}
@ -381,20 +383,20 @@ let realloc_spec us reg ptr siz =
let sub, ms, us = let sub, ms, us =
assign assign
~ws:(Set.add Var.Set.empty reg) ~ws:(Set.add Var.Set.empty reg)
~rs:(Set.union foot.us (Exp.fv siz)) ~rs:(Set.union foot.us (Term.fv siz))
~us ~us
in in
let loc = Exp.var reg in let loc = Term.var reg in
let siz = Exp.rename sub siz in let siz = Term.rename sub siz in
let {us; xs; seg= rseg} = fresh_seg ~loc ~bas:loc ~len:siz ~siz ~xs us in let {us; xs; seg= rseg} = fresh_seg ~loc ~bas:loc ~len:siz ~siz ~xs us in
let a0 = pseg.arr in let a0 = pseg.arr in
let a1 = rseg.arr in let a1 = rseg.arr in
let a2, _, xs = fresh_var "a" us xs in let a2, _, xs = fresh_var "a" us xs in
let post = let post =
Sh.or_ Sh.or_
(Sh.and_ Exp.(eq loc null) (Sh.rename sub foot)) (Sh.and_ Term.(eq loc null) (Sh.rename sub foot))
(Sh.and_ (Sh.and_
Exp.( Term.(
conditional ~cnd:(le len siz) conditional ~cnd:(le len siz)
~thn: ~thn:
(eq (memory ~siz ~arr:a1) (eq (memory ~siz ~arr:a1)
@ -422,21 +424,21 @@ let rallocx_spec us reg ptr siz =
fresh_seg ~loc:ptr ~bas:ptr ~len ~siz:len ~xs us fresh_seg ~loc:ptr ~bas:ptr ~len ~siz:len ~xs us
in in
let pheap = Sh.seg pseg in let pheap = Sh.seg pseg in
let foot = Sh.and_ Exp.(dq siz zero) pheap in let foot = Sh.and_ Term.(dq siz zero) pheap in
let sub, ms, us = let sub, ms, us =
assign ~ws:(Set.add Var.Set.empty reg) ~rs:foot.us ~us assign ~ws:(Set.add Var.Set.empty reg) ~rs:foot.us ~us
in in
let loc = Exp.var reg in let loc = Term.var reg in
let siz = Exp.rename sub siz in let siz = Term.rename sub siz in
let {us; xs; seg= rseg} = fresh_seg ~loc ~bas:loc ~len:siz ~siz ~xs us in let {us; xs; seg= rseg} = fresh_seg ~loc ~bas:loc ~len:siz ~siz ~xs us in
let a0 = pseg.arr in let a0 = pseg.arr in
let a1 = rseg.arr in let a1 = rseg.arr in
let a2, _, xs = fresh_var "a" us xs in let a2, _, xs = fresh_var "a" us xs in
let post = let post =
Sh.or_ Sh.or_
(Sh.and_ Exp.(eq loc null) (Sh.rename sub pheap)) (Sh.and_ Term.(eq loc null) (Sh.rename sub pheap))
(Sh.and_ (Sh.and_
Exp.( Term.(
conditional ~cnd:(le len siz) conditional ~cnd:(le len siz)
~thn: ~thn:
(eq (memory ~siz ~arr:a1) (eq (memory ~siz ~arr:a1)
@ -460,17 +462,17 @@ let rallocx_spec us reg ptr siz =
let xallocx_spec us reg ptr siz ext = let xallocx_spec us reg ptr siz ext =
let len, us, xs = fresh_var "m" us Var.Set.empty in let len, us, xs = fresh_var "m" us Var.Set.empty in
let {us; xs; seg} = fresh_seg ~loc:ptr ~bas:ptr ~len ~siz:len ~xs us in let {us; xs; seg} = fresh_seg ~loc:ptr ~bas:ptr ~len ~siz:len ~xs us in
let foot = Sh.and_ Exp.(dq siz zero) (Sh.seg seg) in let foot = Sh.and_ Term.(dq siz zero) (Sh.seg seg) in
let sub, ms, us = let sub, ms, us =
assign assign
~ws:(Set.add Var.Set.empty reg) ~ws:(Set.add Var.Set.empty reg)
~rs:Set.(union foot.us (union (Exp.fv siz) (Exp.fv ext))) ~rs:Set.(union foot.us (union (Term.fv siz) (Term.fv ext)))
~us ~us
in in
let reg = Exp.var reg in let reg = Term.var reg in
let ptr = Exp.rename sub ptr in let ptr = Term.rename sub ptr in
let siz = Exp.rename sub siz in let siz = Term.rename sub siz in
let ext = Exp.rename sub ext in let ext = Term.rename sub ext in
let {us; xs; seg= seg'} = let {us; xs; seg= seg'} =
fresh_seg ~loc:ptr ~bas:ptr ~len:reg ~siz:reg ~xs us fresh_seg ~loc:ptr ~bas:ptr ~len:reg ~siz:reg ~xs us
in in
@ -479,7 +481,7 @@ let xallocx_spec us reg ptr siz ext =
let a2, _, xs = fresh_var "a" us xs in let a2, _, xs = fresh_var "a" us xs in
let post = let post =
Sh.and_ Sh.and_
Exp.( Term.(
and_ and_
(conditional ~cnd:(le len siz) (conditional ~cnd:(le len siz)
~thn: ~thn:
@ -506,7 +508,7 @@ let sallocx_spec us reg ptr =
let {us; xs; seg} = fresh_seg ~loc:ptr ~bas:ptr ~len ~siz:len ~xs us in let {us; xs; seg} = fresh_seg ~loc:ptr ~bas:ptr ~len ~siz:len ~xs us in
let foot = Sh.seg seg in let foot = Sh.seg seg in
let sub, ms, _ = assign ~ws:(Set.add Var.Set.empty reg) ~rs:foot.us ~us in let sub, ms, _ = assign ~ws:(Set.add Var.Set.empty reg) ~rs:foot.us ~us in
let post = Sh.and_ Exp.(eq (var reg) len) (Sh.rename sub foot) in let post = Sh.and_ Term.(eq (var reg) len) (Sh.rename sub foot) in
{xs; foot; sub; ms; post} {xs; foot; sub; ms; post}
(* { p-[p;m)->⟨m,α⟩ } (* { p-[p;m)->⟨m,α⟩ }
@ -518,7 +520,7 @@ let malloc_usable_size_spec us reg ptr =
let {us; xs; seg} = fresh_seg ~loc:ptr ~bas:ptr ~len ~siz:len ~xs us in let {us; xs; seg} = fresh_seg ~loc:ptr ~bas:ptr ~len ~siz:len ~xs us in
let foot = Sh.seg seg in let foot = Sh.seg seg in
let sub, ms, _ = assign ~ws:(Set.add Var.Set.empty reg) ~rs:foot.us ~us in let sub, ms, _ = assign ~ws:(Set.add Var.Set.empty reg) ~rs:foot.us ~us in
let post = Sh.and_ Exp.(le len (var reg)) (Sh.rename sub foot) in let post = Sh.and_ Term.(le len (var reg)) (Sh.rename sub foot) in
{xs; foot; sub; ms; post} {xs; foot; sub; ms; post}
(* { s≠0 } (* { s≠0 }
@ -527,15 +529,15 @@ let malloc_usable_size_spec us reg ptr =
*) *)
let nallocx_spec us reg siz = let nallocx_spec us reg siz =
let xs = Var.Set.empty in let xs = Var.Set.empty in
let foot = Sh.pure (Exp.dq siz zero) in let foot = Sh.pure (Term.dq siz zero) in
let sub, ms, _ = assign ~ws:(Set.add Var.Set.empty reg) ~rs:foot.us ~us in let sub, ms, _ = assign ~ws:(Set.add Var.Set.empty reg) ~rs:foot.us ~us in
let loc = Exp.var reg in let loc = Term.var reg in
let siz = Exp.rename sub siz in let siz = Term.rename sub siz in
let post = Sh.or_ (null_eq loc) (Sh.pure (Exp.eq loc siz)) in let post = Sh.or_ (null_eq loc) (Sh.pure (Term.eq loc siz)) in
{xs; foot; sub; ms; post} {xs; foot; sub; ms; post}
let size_of_int_mul n = let size_of_int_mul n =
Exp.mul Typ.siz (Option.value_exn (Exp.size_of Typ.siz)) n Term.mul Typ.siz (Option.value_exn (Term.size_of Typ.siz)) n
(* { r-[_;_)->⟨m,_⟩ * i-[_;_)->⟨_,m⟩ * w=0 * n=0 } (* { r-[_;_)->⟨m,_⟩ * i-[_;_)->⟨_,m⟩ * w=0 * n=0 }
* mallctl r i w n * mallctl r i w n
@ -547,8 +549,8 @@ let mallctl_read_spec us r i w n =
let a, _, xs = fresh_var "a" us xs in let a, _, xs = fresh_var "a" us xs in
let foot = let foot =
Sh.and_ Sh.and_
Exp.(eq w null) Term.(eq w null)
(Sh.and_ Exp.(eq n zero) (Sh.star (Sh.seg iseg) (Sh.seg rseg))) (Sh.and_ Term.(eq n zero) (Sh.star (Sh.seg iseg) (Sh.seg rseg)))
in in
let rseg' = {rseg with arr= a} in let rseg' = {rseg with arr= a} in
let post = Sh.star (Sh.seg rseg') (Sh.seg iseg) in let post = Sh.star (Sh.seg rseg') (Sh.seg iseg) in
@ -569,8 +571,8 @@ let mallctlbymib_read_spec us p l r i w n =
let a, _, xs = fresh_var "a" us xs in let a, _, xs = fresh_var "a" us xs in
let foot = let foot =
Sh.and_ Sh.and_
Exp.(eq w null) Term.(eq w null)
(Sh.and_ Exp.(eq n zero) (Sh.star const (Sh.seg rseg))) (Sh.and_ Term.(eq n zero) (Sh.star const (Sh.seg rseg)))
in in
let rseg' = {rseg with arr= a} in let rseg' = {rseg with arr= a} in
let post = Sh.star (Sh.seg rseg') const in let post = Sh.star (Sh.seg rseg') const in
@ -583,7 +585,7 @@ let mallctlbymib_read_spec us p l r i w n =
let mallctl_write_spec us r i w n = let mallctl_write_spec us r i w n =
let {us= _; xs; seg} = fresh_seg ~loc:w ~siz:n us in let {us= _; xs; seg} = fresh_seg ~loc:w ~siz:n us in
let post = Sh.seg seg in let post = Sh.seg seg in
let foot = Sh.and_ Exp.(eq r null) (Sh.and_ Exp.(eq i zero) post) in let foot = Sh.and_ Term.(eq r null) (Sh.and_ Term.(eq i zero) post) in
{xs; foot; sub= Var.Subst.empty; ms= Var.Set.empty; post} {xs; foot; sub= Var.Subst.empty; ms= Var.Set.empty; post}
(* { p-[_;_)->⟨W×l,_⟩ * r=0 * i=0 * w-[_;_)->⟨n,_⟩ } (* { p-[_;_)->⟨W×l,_⟩ * r=0 * i=0 * w-[_;_)->⟨n,_⟩ }
@ -596,7 +598,7 @@ let mallctlbymib_write_spec us p l r i w n =
let {us; xs; seg= pseg} = fresh_seg ~loc:p ~siz:wl us in let {us; xs; seg= pseg} = fresh_seg ~loc:p ~siz:wl us in
let {us= _; xs; seg= wseg} = fresh_seg ~loc:w ~siz:n ~xs us in let {us= _; xs; seg= wseg} = fresh_seg ~loc:w ~siz:n ~xs us in
let post = Sh.star (Sh.seg pseg) (Sh.seg wseg) in let post = Sh.star (Sh.seg pseg) (Sh.seg wseg) in
let foot = Sh.and_ Exp.(eq r null) (Sh.and_ Exp.(eq i zero) post) in let foot = Sh.and_ Term.(eq r null) (Sh.and_ Term.(eq i zero) post) in
{xs; foot; sub= Var.Subst.empty; ms= Var.Set.empty; post} {xs; foot; sub= Var.Subst.empty; ms= Var.Set.empty; post}
let mallctl_specs us r i w n = let mallctl_specs us r i w n =
@ -641,12 +643,14 @@ let strlen_spec us reg ptr =
let sub, ms, _ = assign ~ws:(Set.add Var.Set.empty reg) ~rs:foot.us ~us in let sub, ms, _ = assign ~ws:(Set.add Var.Set.empty reg) ~rs:foot.us ~us in
let {Sh.loc= p; bas= b; len= m; _} = seg in let {Sh.loc= p; bas= b; len= m; _} = seg in
let ret = let ret =
Exp.sub Typ.siz Term.sub Typ.siz
(Exp.sub Typ.siz (Exp.add Typ.siz b m) p) (Term.sub Typ.siz (Term.add Typ.siz b m) p)
(Exp.integer Z.one Typ.siz) (Term.integer Z.one Typ.siz)
in in
let post = let post =
Sh.and_ (Exp.eq (Exp.var reg) (Exp.rename sub ret)) (Sh.rename sub foot) Sh.and_
(Term.eq (Term.var reg) (Term.rename sub ret))
(Sh.rename sub foot)
in in
{xs; foot; sub; ms; post} {xs; foot; sub; ms; post}
@ -705,20 +709,38 @@ let inst : Sh.t -> Llair.inst -> (Sh.t, unit) result =
fun pre inst -> fun pre inst ->
[%Trace.info [%Trace.info
"@[<2>exec inst %a from@ @[{ %a@ }@]@]" Llair.Inst.pp inst Sh.pp pre] ; "@[<2>exec inst %a from@ @[{ %a@ }@]@]" Llair.Inst.pp inst Sh.pp pre] ;
assert (Set.disjoint (Sh.fv pre) (Llair.Inst.locals inst)) ; assert (
Set.disjoint (Sh.fv pre) (Var.Set.of_regs (Llair.Inst.locals inst)) ) ;
let us = pre.us in let us = pre.us in
match inst with match inst with
| Move {reg_exps; _} -> exec_spec pre (move_spec us reg_exps) | Move {reg_exps; _} ->
| Load {reg; ptr; len; _} -> exec_spec pre (load_spec us reg ptr len) exec_spec pre
| Store {ptr; exp; len; _} -> exec_spec pre (store_spec us ptr exp len) (move_spec us
| Memset {dst; byt; len; _} -> exec_spec pre (memset_spec us dst byt len) (Vector.map reg_exps ~f:(fun (r, e) ->
(Var.of_reg r, Term.of_exp e) )))
| Load {reg; ptr; len; _} ->
exec_spec pre
(load_spec us (Var.of_reg reg) (Term.of_exp ptr) (Term.of_exp len))
| Store {ptr; exp; len; _} ->
exec_spec pre
(store_spec us (Term.of_exp ptr) (Term.of_exp exp) (Term.of_exp len))
| Memset {dst; byt; len; _} ->
exec_spec pre
(memset_spec us (Term.of_exp dst) (Term.of_exp byt)
(Term.of_exp len))
| Memcpy {dst; src; len; _} -> | Memcpy {dst; src; len; _} ->
exec_specs pre (memcpy_specs us dst src len) exec_specs pre
(memcpy_specs us (Term.of_exp dst) (Term.of_exp src)
(Term.of_exp len))
| Memmov {dst; src; len; _} -> | Memmov {dst; src; len; _} ->
exec_specs pre (memmov_specs us dst src len) exec_specs pre
| Alloc {reg; num; len; _} -> exec_spec pre (alloc_spec us reg num len) (memmov_specs us (Term.of_exp dst) (Term.of_exp src)
| Free {ptr; _} -> exec_spec pre (free_spec us ptr) (Term.of_exp len))
| Nondet {reg= Some reg; _} -> Ok (kill pre reg) | Alloc {reg; num; len; _} ->
exec_spec pre
(alloc_spec us (Var.of_reg reg) (Term.of_exp num) (Term.of_exp len))
| Free {ptr; _} -> exec_spec pre (free_spec us (Term.of_exp ptr))
| Nondet {reg= Some reg; _} -> Ok (kill pre (Var.of_reg reg))
| Nondet {reg= None; _} -> Ok pre | Nondet {reg= None; _} -> Ok pre
| Abort _ -> Error () | Abort _ -> Error ()
@ -728,13 +750,13 @@ let intrinsic ~skip_throw :
Sh.t Sh.t
-> Var.t option -> Var.t option
-> Var.t -> Var.t
-> Exp.t list -> Term.t list
-> (Sh.t, unit) result option = -> (Sh.t, unit) result option =
fun pre areturn intrinsic actuals -> fun pre areturn intrinsic actuals ->
[%Trace.info [%Trace.info
"@[<2>exec intrinsic@ @[%a%a(@[%a@])@] from@ @[{ %a@ }@]@]" "@[<2>exec intrinsic@ @[%a%a(@[%a@])@] from@ @[{ %a@ }@]@]"
(Option.pp "%a := " Var.pp) (Option.pp "%a := " Var.pp)
areturn Var.pp intrinsic (List.pp ",@ " Exp.pp) (List.rev actuals) areturn Var.pp intrinsic (List.pp ",@ " Term.pp) (List.rev actuals)
Sh.pp pre] ; Sh.pp pre] ;
let us = pre.us in let us = pre.us in
let name = let name =

@ -7,9 +7,9 @@
(** Symbolic Execution *) (** Symbolic Execution *)
val assume : Sh.t -> Exp.t -> Sh.t option val assume : Sh.t -> Term.t -> Sh.t option
val kill : Sh.t -> Var.t -> Sh.t val kill : Sh.t -> Var.t -> Sh.t
val move : Sh.t -> Var.t -> Exp.t -> Sh.t val move : Sh.t -> Var.t -> Term.t -> Sh.t
val inst : Sh.t -> Llair.inst -> (Sh.t, unit) result val inst : Sh.t -> Llair.inst -> (Sh.t, unit) result
val intrinsic : val intrinsic :
@ -17,5 +17,5 @@ val intrinsic :
-> Sh.t -> Sh.t
-> Var.t option -> Var.t option
-> Var.t -> Var.t
-> Exp.t list -> Term.t list
-> (Sh.t, unit) result option -> (Sh.t, unit) result option

@ -9,14 +9,14 @@
[@@@warning "+9"] [@@@warning "+9"]
type seg = {loc: Exp.t; bas: Exp.t; len: Exp.t; siz: Exp.t; arr: Exp.t} type seg = {loc: Term.t; bas: Term.t; len: Term.t; siz: Term.t; arr: Term.t}
[@@deriving compare, equal, sexp] [@@deriving compare, equal, sexp]
type starjunction = type starjunction =
{ us: Var.Set.t { us: Var.Set.t
; xs: Var.Set.t ; xs: Var.Set.t
; cong: Equality.t ; cong: Equality.t
; pure: Exp.t list ; pure: Term.t list
; heap: seg list ; heap: seg list
; djns: disjunction list } ; djns: disjunction list }
[@@deriving compare, equal, sexp] [@@deriving compare, equal, sexp]
@ -29,12 +29,12 @@ let map_seg {loc; bas; len; siz; arr} ~f =
{loc= f loc; bas= f bas; len= f len; siz= f siz; arr= f arr} {loc= f loc; bas= f bas; len= f len; siz= f siz; arr= f arr}
let pp_seg ?is_x fs {loc; bas; len; siz; arr} = let pp_seg ?is_x fs {loc; bas; len; siz; arr} =
let exp_pp = Exp.pp_full ?is_x in let term_pp = Term.pp_full ?is_x in
Format.fprintf fs "@[<2>%a@ @[@[-[%a)->@]@ %a@]@]" exp_pp loc Format.fprintf fs "@[<2>%a@ @[@[-[%a)->@]@ %a@]@]" term_pp loc
(fun fs (bas, len) -> (fun fs (bas, len) ->
if (not (Exp.equal loc bas)) || not (Exp.equal len siz) then if (not (Term.equal loc bas)) || not (Term.equal len siz) then
Format.fprintf fs " %a, %a " exp_pp bas exp_pp len ) Format.fprintf fs " %a, %a " term_pp bas term_pp len )
(bas, len) exp_pp (Exp.memory ~siz ~arr) (bas, len) term_pp (Term.memory ~siz ~arr)
let pp_seg_norm cong fs seg = let pp_seg_norm cong fs seg =
pp_seg fs (map_seg seg ~f:(Equality.normalize cong)) pp_seg fs (map_seg seg ~f:(Equality.normalize cong))
@ -46,7 +46,7 @@ let pp_us ?(pre = ("" : _ fmt)) fs us =
let rec pp vs all_xs fs {us; xs; cong; pure; heap; djns} = let rec pp vs all_xs fs {us; xs; cong; pure; heap; djns} =
Format.pp_open_hvbox fs 0 ; Format.pp_open_hvbox fs 0 ;
let all_xs = Set.union all_xs xs in let all_xs = Set.union all_xs xs in
let is_x var = Set.mem all_xs (Option.value_exn (Var.of_exp var)) in let is_x var = Set.mem all_xs (Option.value_exn (Var.of_term var)) in
pp_us fs us ; pp_us fs us ;
let xs_i_vs, xs_d_vs = Set.inter_diff vs xs in let xs_i_vs, xs_d_vs = Set.inter_diff vs xs in
if not (Set.is_empty xs_i_vs) then ( if not (Set.is_empty xs_i_vs) then (
@ -57,15 +57,15 @@ let rec pp vs all_xs fs {us; xs; cong; pure; heap; djns} =
let first = Equality.is_true cong in let first = Equality.is_true cong in
if not first then Format.fprintf fs " " ; if not first then Format.fprintf fs " " ;
Equality.pp_classes ~is_x fs cong ; Equality.pp_classes ~is_x fs cong ;
let pure_exps = let pure_terms =
List.filter_map pure ~f:(fun e -> List.filter_map pure ~f:(fun e ->
let e' = Equality.normalize cong e in let e' = Equality.normalize cong e in
if Exp.is_true e' then None else Some e' ) if Term.is_true e' then None else Some e' )
in in
List.pp List.pp
~pre:(if first then " " else "@ @<2>∧ ") ~pre:(if first then " " else "@ @<2>∧ ")
"@ @<2>∧ " (Exp.pp_full ~is_x) fs pure_exps ; "@ @<2>∧ " (Term.pp_full ~is_x) fs pure_terms ;
let first = first && List.is_empty pure_exps in let first = first && List.is_empty pure_terms in
if List.is_empty heap then if List.is_empty heap then
Format.fprintf fs Format.fprintf fs
( if first then if List.is_empty djns then " emp" else "" ( if first then if List.is_empty djns then " emp" else ""
@ -78,11 +78,12 @@ let rec pp vs all_xs fs {us; xs; cong; pure; heap; djns} =
(List.map ~f:(map_seg ~f:(Equality.normalize cong)) heap) (List.map ~f:(map_seg ~f:(Equality.normalize cong)) heap)
~compare:(fun s1 s2 -> ~compare:(fun s1 s2 ->
let b_o = function let b_o = function
| Exp.App {op= App {op= Add _; arg}; arg= Integer {data; _}} -> | Term.App {op= App {op= Add _; arg}; arg= Integer {data; _}}
->
(arg, data) (arg, data)
| e -> (e, Z.zero) | e -> (e, Z.zero)
in in
[%compare: Exp.t * (Exp.t * Z.t)] [%compare: Term.t * (Term.t * Z.t)]
(s1.bas, b_o s1.loc) (s1.bas, b_o s1.loc)
(s2.bas, b_o s2.loc) )) ; (s2.bas, b_o s2.loc) )) ;
let first = first && List.is_empty heap in let first = first && List.is_empty heap in
@ -105,34 +106,34 @@ and pp_djn vs all_xs fs = function
let pp = pp Var.Set.empty Var.Set.empty let pp = pp Var.Set.empty Var.Set.empty
let pp_djn = pp_djn Var.Set.empty Var.Set.empty let pp_djn = pp_djn Var.Set.empty Var.Set.empty
let fold_exps_seg {loc; bas; len; siz; arr} ~init ~f = let fold_terms_seg {loc; bas; len; siz; arr} ~init ~f =
let f b z = Exp.fold_exps b ~init:z ~f in let f b z = Term.fold_terms b ~init:z ~f in
f loc (f bas (f len (f siz (f arr init)))) f loc (f bas (f len (f siz (f arr init))))
let fold_vars_seg seg ~init ~f = let fold_vars_seg seg ~init ~f =
fold_exps_seg seg ~init ~f:(fun init -> Exp.fold_vars ~f ~init) fold_terms_seg seg ~init ~f:(fun init -> Term.fold_vars ~f ~init)
let fv_seg seg = fold_vars_seg seg ~f:Set.add ~init:Var.Set.empty let fv_seg seg = fold_vars_seg seg ~f:Set.add ~init:Var.Set.empty
let fold_exps fold_exps {us= _; xs= _; cong; pure; heap; djns} ~init ~f = let fold_terms fold_terms {us= _; xs= _; cong; pure; heap; djns} ~init ~f =
Equality.fold_exps ~init cong ~f Equality.fold_terms ~init cong ~f
|> fun init -> |> fun init ->
List.fold ~init pure ~f:(fun init -> Exp.fold_exps ~f ~init) List.fold ~init pure ~f:(fun init -> Term.fold_terms ~f ~init)
|> fun init -> |> fun init ->
List.fold ~init heap ~f:(fun init -> fold_exps_seg ~f ~init) List.fold ~init heap ~f:(fun init -> fold_terms_seg ~f ~init)
|> fun init -> |> fun init ->
List.fold ~init djns ~f:(fun init -> List.fold ~init ~f:fold_exps) List.fold ~init djns ~f:(fun init -> List.fold ~init ~f:fold_terms)
let rec fv_union init q = let rec fv_union init q =
Set.diff Set.diff
(fold_exps fv_union q ~init ~f:(fun init -> (fold_terms fv_union q ~init ~f:(fun init ->
Exp.fold_vars ~f:Set.add ~init )) Term.fold_vars ~f:Set.add ~init ))
q.xs q.xs
let fv q = fv_union Var.Set.empty q let fv q = fv_union Var.Set.empty q
let invariant_pure = function let invariant_pure = function
| Exp.Integer {data; typ} -> | Term.Integer {data; typ} ->
assert (Typ.equal Typ.bool typ) ; assert (Typ.equal Typ.bool typ) ;
assert (not (Z.is_false data)) assert (not (Z.is_false data))
| _ -> assert true | _ -> assert true
@ -186,11 +187,11 @@ let rec simplify {us; xs; cong; pure; heap; djns} =
(** Quantification and Vocabulary *) (** Quantification and Vocabulary *)
let rename_seg sub ({loc; bas; len; siz; arr} as h) = let rename_seg sub ({loc; bas; len; siz; arr} as h) =
let loc = Exp.rename sub loc in let loc = Term.rename sub loc in
let bas = Exp.rename sub bas in let bas = Term.rename sub bas in
let len = Exp.rename sub len in let len = Term.rename sub len in
let siz = Exp.rename sub siz in let siz = Term.rename sub siz in
let arr = Exp.rename sub arr in let arr = Term.rename sub arr in
( if ( if
loc == h.loc && bas == h.bas && len == h.len && siz == h.siz loc == h.loc && bas == h.bas && len == h.len && siz == h.siz
&& arr == h.arr && arr == h.arr
@ -203,7 +204,7 @@ let rename_seg sub ({loc; bas; len; siz; arr} as h) =
invariant *) invariant *)
let rec apply_subst sub ({us= _; xs= _; cong; pure; heap; djns} as q) = let rec apply_subst sub ({us= _; xs= _; cong; pure; heap; djns} as q) =
let cong = Equality.rename cong sub in let cong = Equality.rename cong sub in
let pure = List.map_preserving_phys_equal pure ~f:(Exp.rename sub) in let pure = List.map_preserving_phys_equal pure ~f:(Term.rename sub) in
let heap = List.map_preserving_phys_equal heap ~f:(rename_seg sub) in let heap = List.map_preserving_phys_equal heap ~f:(rename_seg sub) in
let djns = let djns =
List.map_preserving_phys_equal djns ~f:(fun d -> List.map_preserving_phys_equal djns ~f:(fun d ->
@ -375,10 +376,10 @@ let or_ q1 q2 =
invariant q ; invariant q ;
assert (Set.equal q.us (Set.union q1.us q2.us))] assert (Set.equal q.us (Set.union q1.us q2.us))]
let rec pure (e : Exp.t) = let rec pure (e : Term.t) =
[%Trace.call fun {pf} -> pf "%a" Exp.pp e] [%Trace.call fun {pf} -> pf "%a" Term.pp e]
; ;
let us = Exp.fv e in let us = Term.fv e in
( match e with ( match e with
| Integer {data; typ= Integer {bits= 1}} -> | Integer {data; typ= Integer {bits= 1}} ->
if Z.is_false data then false_ us else emp if Z.is_false data then false_ us else emp
@ -388,7 +389,7 @@ let rec pure (e : Exp.t) =
-> ->
or_ or_
(star (pure cnd) (pure thn)) (star (pure cnd) (pure thn))
(star (pure (Exp.not_ Typ.bool cnd)) (pure els)) (star (pure (Term.not_ Typ.bool cnd)) (pure els))
| App {op= App {op= Eq; arg= e1}; arg= e2} -> | App {op= App {op= Eq; arg= e1}; arg= e2} ->
let cong = Equality.(and_eq e1 e2 true_) in let cong = Equality.(and_eq e1 e2 true_) in
if Equality.is_false cong then false_ us if Equality.is_false cong then false_ us
@ -401,7 +402,7 @@ let and_ e q = star (pure e) q
let seg pt = let seg pt =
let us = fv_seg pt in let us = fv_seg pt in
if Exp.equal Exp.null pt.loc then false_ us if Term.equal Term.null pt.loc then false_ us
else {emp with us; heap= [pt]} |> check invariant else {emp with us; heap= [pt]} |> check invariant
(** Update *) (** Update *)
@ -423,9 +424,10 @@ let is_emp = function
let is_false = function let is_false = function
| {djns= [[]]; _} -> true | {djns= [[]]; _} -> true
| {cong; pure; heap; _} -> | {cong; pure; heap; _} ->
List.exists pure ~f:(fun b -> Exp.is_false (Equality.normalize cong b)) List.exists pure ~f:(fun b ->
Term.is_false (Equality.normalize cong b) )
|| List.exists heap ~f:(fun seg -> || List.exists heap ~f:(fun seg ->
Equality.entails_eq cong seg.loc Exp.null ) Equality.entails_eq cong seg.loc Term.null )
let rec pure_approx ({us; xs; cong; pure; heap= _; djns} as q) = let rec pure_approx ({us; xs; cong; pure; heap= _; djns} as q) =
let heap = emp.heap in let heap = emp.heap in

@ -11,13 +11,13 @@
size [siz], contained in an enclosing allocation-block starting at [bas] size [siz], contained in an enclosing allocation-block starting at [bas]
of length [len]. Byte-array expressions are either [Var]iables or of length [len]. Byte-array expressions are either [Var]iables or
[Splat] vectors. *) [Splat] vectors. *)
type seg = {loc: Exp.t; bas: Exp.t; len: Exp.t; siz: Exp.t; arr: Exp.t} type seg = {loc: Term.t; bas: Term.t; len: Term.t; siz: Term.t; arr: Term.t}
type starjunction = private type starjunction = private
{ us: Var.Set.t (** vocabulary / variable context of formula *) { us: Var.Set.t (** vocabulary / variable context of formula *)
; xs: Var.Set.t (** existentially-bound variables *) ; xs: Var.Set.t (** existentially-bound variables *)
; cong: Equality.t (** congruence induced by rest of formula *) ; cong: Equality.t (** congruence induced by rest of formula *)
; pure: Exp.t list (** conjunction of pure boolean constraints *) ; pure: Term.t list (** conjunction of pure boolean constraints *)
; heap: seg list (** star-conjunction of segment atomic formulas *) ; heap: seg list (** star-conjunction of segment atomic formulas *)
; djns: disjunction list (** star-conjunction of disjunctions *) } ; djns: disjunction list (** star-conjunction of disjunctions *) }
@ -25,7 +25,7 @@ and disjunction = starjunction list
type t = starjunction [@@deriving equal, compare, sexp] type t = starjunction [@@deriving equal, compare, sexp]
val pp_seg : ?is_x:(Exp.t -> bool) -> seg pp val pp_seg : ?is_x:(Term.t -> bool) -> seg pp
val pp_seg_norm : Equality.t -> seg pp val pp_seg_norm : Equality.t -> seg pp
val pp_us : ?pre:('a, 'a) fmt -> Var.Set.t pp val pp_us : ?pre:('a, 'a) fmt -> Var.Set.t pp
val pp : t pp val pp : t pp
@ -53,10 +53,10 @@ val or_ : t -> t -> t
(** Disjoin formulas, extending to a common vocabulary, and avoiding (** Disjoin formulas, extending to a common vocabulary, and avoiding
capturing existentials. *) capturing existentials. *)
val pure : Exp.t -> t val pure : Term.t -> t
(** Atomic pure boolean constraint formula. *) (** Atomic pure boolean constraint formula. *)
val and_ : Exp.t -> t -> t val and_ : Term.t -> t -> t
(** Conjoin a boolean constraint to a formula. *) (** Conjoin a boolean constraint to a formula. *)
val and_cong : Equality.t -> t -> t val and_cong : Equality.t -> t -> t
@ -65,7 +65,7 @@ val and_cong : Equality.t -> t -> t
(** Update *) (** Update *)
val with_pure : Exp.t list -> t -> t val with_pure : Term.t list -> t -> t
(** [with_pure pure q] is [{q with pure}], which assumes that [q.pure] and (** [with_pure pure q] is [{q with pure}], which assumes that [q.pure] and
[pure] are defined in the same vocabulary, induce the same congruence, [pure] are defined in the same vocabulary, induce the same congruence,
etc. It can essentially only be used when [pure] is logically equivalent etc. It can essentially only be used when [pure] is logically equivalent

@ -19,29 +19,38 @@ let report_fmt_thunk = Fn.flip pp
let init globals = let init globals =
Vector.fold globals ~init:Sh.emp ~f:(fun q -> function Vector.fold globals ~init:Sh.emp ~f:(fun q -> function
| {Global.var; init= Some (arr, siz)} -> | {Global.reg; init= Some (arr, siz)} ->
let loc = Exp.var var in let loc = Term.var (Var.of_reg reg) in
let len = Exp.integer (Z.of_int siz) Typ.siz in let len = Term.integer (Z.of_int siz) Typ.siz in
let arr = Term.of_exp arr in
Sh.star q (Sh.seg {loc; bas= loc; len; siz= len; arr}) Sh.star q (Sh.seg {loc; bas= loc; len; siz= len; arr})
| _ -> q ) | _ -> q )
let join l r = Some (Sh.or_ l r) let join l r = Some (Sh.or_ l r)
let is_false = Sh.is_false let is_false = Sh.is_false
let exec_assume = Exec.assume let exec_assume q b = Exec.assume q (Term.of_exp b)
let exec_kill = Exec.kill let exec_kill q r = Exec.kill q (Var.of_reg r)
let exec_move = Exec.move let exec_move q r e = Exec.move q (Var.of_reg r) (Term.of_exp e)
let exec_inst = Exec.inst let exec_inst = Exec.inst
let exec_intrinsic = Exec.intrinsic
let exec_intrinsic ~skip_throw q r i es =
Exec.intrinsic ~skip_throw q
(Option.map ~f:Var.of_reg r)
(Var.of_reg i)
(List.map ~f:Term.of_exp es)
let dnf = Sh.dnf let dnf = Sh.dnf
let exp_eq_class_has_only_vars_in fvs cong exp = let term_eq_class_has_only_vars_in fvs cong term =
[%Trace.call fun {pf} -> [%Trace.call fun {pf} ->
pf "@[<v> fvs: @[%a@] @,cong: @[%a@] @,exp: @[%a@]@]" Var.Set.pp fvs pf "@[<v> fvs: @[%a@] @,cong: @[%a@] @,term: @[%a@]@]" Var.Set.pp fvs
Equality.pp cong Exp.pp exp] Equality.pp cong Term.pp term]
; ;
let exp_has_only_vars_in fvs exp = Set.is_subset (Exp.fv exp) ~of_:fvs in let term_has_only_vars_in fvs term =
let exp_eq_class = Equality.class_of cong exp in Set.is_subset (Term.fv term) ~of_:fvs
List.exists ~f:(exp_has_only_vars_in fvs) exp_eq_class in
let term_eq_class = Equality.class_of cong term in
List.exists ~f:(term_has_only_vars_in fvs) term_eq_class
|> |>
[%Trace.retn fun {pf} -> pf "%b"] [%Trace.retn fun {pf} -> pf "%b"]
@ -55,16 +64,16 @@ let garbage_collect (q : t) ~wrt =
else else
let new_set = let new_set =
List.fold ~init:current q.heap ~f:(fun current seg -> List.fold ~init:current q.heap ~f:(fun current seg ->
if exp_eq_class_has_only_vars_in current q.cong seg.loc then if term_eq_class_has_only_vars_in current q.cong seg.loc then
List.fold (Equality.class_of q.cong seg.arr) ~init:current List.fold (Equality.class_of q.cong seg.arr) ~init:current
~f:(fun c e -> Set.union c (Exp.fv e)) ~f:(fun c e -> Set.union c (Term.fv e))
else current ) else current )
in in
all_reachable_vars current new_set q all_reachable_vars current new_set q
in in
let r_vars = all_reachable_vars Var.Set.empty wrt q in let r_vars = all_reachable_vars Var.Set.empty wrt q in
Sh.filter_heap q ~f:(fun seg -> Sh.filter_heap q ~f:(fun seg ->
exp_eq_class_has_only_vars_in r_vars q.cong seg.loc ) term_eq_class_has_only_vars_in r_vars q.cong seg.loc )
|> |>
[%Trace.retn fun {pf} -> pf "%a" pp] [%Trace.retn fun {pf} -> pf "%a" pp]
@ -79,15 +88,19 @@ let call ~summaries ~globals actuals areturn formals ~locals q =
pf pf
"@[<hv>actuals: (@[%a@])@ formals: (@[%a@])@ locals: {@[%a@]}@ \ "@[<hv>actuals: (@[%a@])@ formals: (@[%a@])@ locals: {@[%a@]}@ \
globals: {@[%a@]}@ q: %a@]" globals: {@[%a@]}@ q: %a@]"
(List.pp ",@ " Exp.pp) (List.rev actuals) (List.pp ",@ " Var.pp) (List.pp ",@ " Exp.pp) (List.rev actuals) (List.pp ",@ " Reg.pp)
(List.rev formals) Var.Set.pp locals Var.Set.pp globals pp q] (List.rev formals) Reg.Set.pp locals Reg.Set.pp globals pp q]
; ;
let actuals = List.map ~f:Term.of_exp actuals in
let areturn = Option.map ~f:Var.of_reg areturn in
let formals = List.map ~f:Var.of_reg formals in
let locals = Var.Set.of_regs locals in
let q', freshen_locals = let q', freshen_locals =
Sh.freshen q ~wrt:(Set.add_list formals locals) Sh.freshen q ~wrt:(Set.add_list formals locals)
in in
let and_eq q formal actual = let and_eq q formal actual =
let actual' = Exp.rename freshen_locals actual in let actual' = Term.rename freshen_locals actual in
Sh.and_ (Exp.eq (Exp.var formal) actual') q Sh.and_ (Term.eq (Term.var formal) actual') q
in in
let and_eqs formals actuals q = let and_eqs formals actuals q =
List.fold2_exn ~f:and_eq formals actuals ~init:q List.fold2_exn ~f:and_eq formals actuals ~init:q
@ -101,7 +114,8 @@ let call ~summaries ~globals actuals areturn formals ~locals q =
them *) them *)
let formals_set = Var.Set.of_list formals in let formals_set = Var.Set.of_list formals in
let function_summary_pre = let function_summary_pre =
garbage_collect q'' ~wrt:(Set.union formals_set globals) garbage_collect q''
~wrt:(Set.union formals_set (Var.Set.of_regs globals))
in in
[%Trace.info "function summary pre %a" pp function_summary_pre] ; [%Trace.info "function summary pre %a" pp function_summary_pre] ;
let foot = Sh.exists formals_set function_summary_pre in let foot = Sh.exists formals_set function_summary_pre in
@ -124,8 +138,9 @@ let recursion_beyond_bound = `prune
(** Leave scope of locals: existentially quantify locals. *) (** Leave scope of locals: existentially quantify locals. *)
let post locals _ q = let post locals _ q =
[%Trace.call fun {pf} -> [%Trace.call fun {pf} ->
pf "@[<hv>locals: {@[%a@]}@ q: %a@]" Var.Set.pp locals Sh.pp q] pf "@[<hv>locals: {@[%a@]}@ q: %a@]" Reg.Set.pp locals Sh.pp q]
; ;
let locals = Var.Set.of_regs locals in
Sh.exists locals q Sh.exists locals q
|> |>
[%Trace.retn fun {pf} -> pf "%a" Sh.pp] [%Trace.retn fun {pf} -> pf "%a" Sh.pp]
@ -136,13 +151,15 @@ let post locals _ q =
let retn formals freturn {areturn; subst; frame} q = let retn formals freturn {areturn; subst; frame} q =
[%Trace.call fun {pf} -> [%Trace.call fun {pf} ->
pf "@[<v>formals: {@[%a@]}@ subst: %a@ q: %a@ frame: %a@]" pf "@[<v>formals: {@[%a@]}@ subst: %a@ q: %a@ frame: %a@]"
(List.pp ", " Var.pp) formals Var.Subst.pp (Var.Subst.invert subst) pp (List.pp ", " Reg.pp) formals Var.Subst.pp (Var.Subst.invert subst) pp
q pp frame] q pp frame]
; ;
let formals = List.map ~f:Var.of_reg formals in
let freturn = Option.map ~f:Var.of_reg freturn in
let q = let q =
match (areturn, freturn) with match (areturn, freturn) with
| Some areturn, Some freturn -> exec_move q areturn (Exp.var freturn) | Some areturn, Some freturn -> Exec.move q areturn (Term.var freturn)
| Some areturn, None -> exec_kill q areturn | Some areturn, None -> Exec.kill q areturn
| _ -> q | _ -> q
in in
let q = Sh.exists (Set.add_list formals (Var.Set.of_option freturn)) q in let q = Sh.exists (Set.add_list formals (Var.Set.of_option freturn)) q in
@ -152,8 +169,8 @@ let retn formals freturn {areturn; subst; frame} q =
[%Trace.retn fun {pf} -> pf "%a" pp] [%Trace.retn fun {pf} -> pf "%a" pp]
let resolve_callee lookup ptr q = let resolve_callee lookup ptr q =
match Var.of_exp ptr with match Reg.of_exp ptr with
| Some callee -> (lookup (Var.name callee), q) | Some callee -> (lookup (Reg.name callee), q)
| None -> ([], q) | None -> ([], q)
type summary = {xs: Var.Set.t; foot: t; post: t} type summary = {xs: Var.Set.t; foot: t; post: t}
@ -164,16 +181,18 @@ let pp_summary fs {xs; foot; post} =
let create_summary ~locals ~formals ~entry ~current:(post : Sh.t) = let create_summary ~locals ~formals ~entry ~current:(post : Sh.t) =
[%Trace.call fun {pf} -> [%Trace.call fun {pf} ->
pf "formals %a@ entry: %a@ current: %a" Var.Set.pp formals pp entry pp pf "formals %a@ entry: %a@ current: %a" Reg.Set.pp formals pp entry pp
post] post]
; ;
let locals = Var.Set.of_regs locals in
let formals = Var.Set.of_regs formals in
let foot = Sh.exists locals entry in let foot = Sh.exists locals entry in
let foot, subst = Sh.freshen ~wrt:(Set.union foot.us post.us) foot in let foot, subst = Sh.freshen ~wrt:(Set.union foot.us post.us) foot in
let restore_formals q = let restore_formals q =
Set.fold formals ~init:q ~f:(fun q var -> Set.fold formals ~init:q ~f:(fun q var ->
let var = Exp.var var in let var = Term.var var in
let renamed_var = Exp.rename subst var in let renamed_var = Term.rename subst var in
Sh.and_ (Exp.eq renamed_var var) q ) Sh.and_ (Term.eq renamed_var var) q )
in in
(* Add back the original formals name *) (* Add back the original formals name *)
let post = Sh.rename subst post in let post = Sh.rename subst post in
@ -227,11 +246,11 @@ let%test_module _ =
let n_, wrt = Var.fresh "n" ~wrt let n_, wrt = Var.fresh "n" ~wrt
let b_, wrt = Var.fresh "b" ~wrt let b_, wrt = Var.fresh "b" ~wrt
let end_, _ = Var.fresh "end" ~wrt let end_, _ = Var.fresh "end" ~wrt
let a = Exp.var a_ let a = Term.var a_
let main = Exp.var main_ let main = Term.var main_
let b = Exp.var b_ let b = Term.var b_
let n = Exp.var n_ let n = Term.var n_
let endV = Exp.var end_ let endV = Term.var end_
let seg_main = Sh.seg {loc= main; bas= b; len= n; siz= n; arr= a} let seg_main = Sh.seg {loc= main; bas= b; len= n; siz= n; arr= a}
let seg_a = Sh.seg {loc= a; bas= b; len= n; siz= n; arr= endV} let seg_a = Sh.seg {loc= a; bas= b; len= n; siz= n; arr= endV}
let seg_cycle = Sh.seg {loc= a; bas= b; len= n; siz= n; arr= main} let seg_cycle = Sh.seg {loc= a; bas= b; len= n; siz= n; arr= main}

@ -12,8 +12,8 @@ include Domain_sig.Dom
(* formals should include all the parameters of the summary. That is both (* formals should include all the parameters of the summary. That is both
formals and globals. *) formals and globals. *)
val create_summary : val create_summary :
locals:Var.Set.t locals:Reg.Set.t
-> formals:Var.Set.t -> formals:Reg.Set.t
-> entry:t -> entry:t
-> current:t -> current:t
-> summary * t -> summary * t

@ -13,13 +13,13 @@ let%test_module _ =
let pp = Format.printf "@\n%a@." Sh.pp let pp = Format.printf "@\n%a@." Sh.pp
let pp_djn = Format.printf "@\n%a@." Sh.pp_djn let pp_djn = Format.printf "@\n%a@." Sh.pp_djn
let ( ~$ ) = Var.Set.of_list let ( ~$ ) = Var.Set.of_list
let ( ! ) i = Exp.integer (Z.of_int i) Typ.siz let ( ! ) i = Term.integer (Z.of_int i) Typ.siz
let ( = ) = Exp.eq let ( = ) = Term.eq
let wrt = Var.Set.empty let wrt = Var.Set.empty
let x_, wrt = Var.fresh "x" ~wrt let x_, wrt = Var.fresh "x" ~wrt
let y_, _ = Var.fresh "y" ~wrt let y_, _ = Var.fresh "y" ~wrt
let x = Exp.var x_ let x = Term.var x_
let y = Exp.var y_ let y = Term.var y_
let%expect_test _ = let%expect_test _ =
let p = Sh.(exists ~$[x_] (extend_us ~$[x_] emp)) in let p = Sh.(exists ~$[x_] (extend_us ~$[x_] emp)) in

@ -44,15 +44,15 @@ let fresh_var name vs zs ~wrt =
let v, wrt = Var.fresh name ~wrt in let v, wrt = Var.fresh name ~wrt in
let vs = Set.add vs v in let vs = Set.add vs v in
let zs = Set.add zs v in let zs = Set.add zs v in
let v = Exp.var v in let v = Term.var v in
(v, vs, zs, wrt) (v, vs, zs, wrt)
type occurrences = Zero | One of Var.t | Many type occurrences = Zero | One of Var.t | Many
let single_existential_occurrence xs exp = let single_existential_occurrence xs term =
let exception Multiple_existential_occurrences in let exception Multiple_existential_occurrences in
try try
Exp.fold_vars exp ~init:Zero ~f:(fun seen var -> Term.fold_vars term ~init:Zero ~f:(fun seen var ->
if not (Set.mem xs var) then seen if not (Set.mem xs var) then seen
else else
match seen with match seen with
@ -61,32 +61,32 @@ let single_existential_occurrence xs exp =
with Multiple_existential_occurrences -> Many with Multiple_existential_occurrences -> Many
let special_cases xs = function let special_cases xs = function
| Exp.App {op= App {op= Eq; arg= Var _}; arg= Var _} as e -> | Term.App {op= App {op= Eq; arg= Var _}; arg= Var _} as e ->
if Set.is_subset (Exp.fv e) ~of_:xs then Exp.bool true else e if Set.is_subset (Term.fv e) ~of_:xs then Term.bool true else e
| e -> e | e -> e
let excise_exp ({us; min; xs} as goal) pure exp = let excise_term ({us; min; xs} as goal) pure term =
let exp' = Equality.normalize min.cong exp in let term' = Equality.normalize min.cong term in
let exp' = special_cases xs exp' in let term' = special_cases xs term' in
[%Trace.info "exp': %a" Exp.pp exp'] ; [%Trace.info "term': %a" Term.pp term'] ;
if Exp.is_true exp' then Some ({goal with pgs= true}, pure) if Term.is_true term' then Some ({goal with pgs= true}, pure)
else else
match single_existential_occurrence xs exp' with match single_existential_occurrence xs term' with
| Zero -> None | Zero -> None
| One x -> | One x ->
Some Some
( { goal with ( { goal with
us= Set.add us x us= Set.add us x
; min= Sh.and_ exp' min ; min= Sh.and_ term' min
; xs= Set.remove xs x ; xs= Set.remove xs x
; pgs= true } ; pgs= true }
, pure ) , pure )
| Many -> Some (goal, exp' :: pure) | Many -> Some (goal, term' :: pure)
let excise_pure ({sub} as goal) = let excise_pure ({sub} as goal) =
[%Trace.info "@[<2>excise_pure@ %a@]" pp goal] ; [%Trace.info "@[<2>excise_pure@ %a@]" pp goal] ;
List.fold_option sub.pure ~init:(goal, []) ~f:(fun (goal, pure) exp -> List.fold_option sub.pure ~init:(goal, []) ~f:(fun (goal, pure) term ->
excise_exp goal pure exp ) excise_term goal pure term )
>>| fun (goal, pure) -> {goal with sub= Sh.with_pure pure sub} >>| fun (goal, pure) -> {goal with sub= Sh.with_pure pure sub}
(* [k; o) (* [k; o)
@ -111,8 +111,8 @@ let excise_seg_same ({com; min; sub} as goal) msg ssg =
let com = Sh.star (Sh.seg msg) com in let com = Sh.star (Sh.seg msg) com in
let min = Sh.rem_seg msg min in let min = Sh.rem_seg msg min in
let sub = let sub =
Sh.and_ (Exp.eq b b') Sh.and_ (Term.eq b b')
(Sh.and_ (Exp.eq m m') (Sh.and_ (Exp.eq a a') (Sh.rem_seg ssg sub))) (Sh.and_ (Term.eq m m') (Sh.and_ (Term.eq a a') (Sh.rem_seg ssg sub)))
in in
{goal with com; min; sub} {goal with com; min; sub}
@ -136,24 +136,24 @@ let excise_seg_sub_prefix ({us; com; min; xs; sub; zs} as goal) msg ssg o_n
msg (Sh.pp_seg_norm sub.cong) ssg pp goal] ; msg (Sh.pp_seg_norm sub.cong) ssg pp goal] ;
let {Sh.loc= k; bas= b; len= m; siz= o; arr= a} = msg in let {Sh.loc= k; bas= b; len= m; siz= o; arr= a} = msg in
let {Sh.bas= b'; len= m'; siz= n; arr= a'} = ssg in let {Sh.bas= b'; len= m'; siz= n; arr= a'} = ssg in
let o_n = Exp.integer o_n Typ.siz in let o_n = Term.integer o_n Typ.siz in
let a0, us, zs, wrt = fresh_var "a0" us zs ~wrt:(Set.union us xs) in let a0, us, zs, wrt = fresh_var "a0" us zs ~wrt:(Set.union us xs) in
let a1, us, zs, _ = fresh_var "a1" us zs ~wrt in let a1, us, zs, _ = fresh_var "a1" us zs ~wrt in
let com = Sh.star (Sh.seg {msg with siz= n; arr= a0}) com in let com = Sh.star (Sh.seg {msg with siz= n; arr= a0}) com in
let min = let min =
Sh.and_ Sh.and_
(Exp.eq (Term.eq
(Exp.memory ~siz:o ~arr:a) (Term.memory ~siz:o ~arr:a)
(Exp.concat (Term.concat
[|Exp.memory ~siz:n ~arr:a0; Exp.memory ~siz:o_n ~arr:a1|])) [|Term.memory ~siz:n ~arr:a0; Term.memory ~siz:o_n ~arr:a1|]))
(Sh.star (Sh.star
(Sh.seg (Sh.seg
{loc= Exp.add Typ.ptr k n; bas= b; len= m; siz= o_n; arr= a1}) {loc= Term.add Typ.ptr k n; bas= b; len= m; siz= o_n; arr= a1})
(Sh.rem_seg msg min)) (Sh.rem_seg msg min))
in in
let sub = let sub =
Sh.and_ (Exp.eq b b') Sh.and_ (Term.eq b b')
(Sh.and_ (Exp.eq m m') (Sh.and_ (Exp.eq a0 a') (Sh.rem_seg ssg sub))) (Sh.and_ (Term.eq m m') (Sh.and_ (Term.eq a0 a') (Sh.rem_seg ssg sub)))
in in
{goal with us; com; min; sub; zs} {goal with us; com; min; sub; zs}
@ -178,21 +178,22 @@ let excise_seg_min_prefix ({us; com; min; xs; sub; zs} as goal) msg ssg n_o
msg (Sh.pp_seg_norm sub.cong) ssg pp goal] ; msg (Sh.pp_seg_norm sub.cong) ssg pp goal] ;
let {Sh.bas= b; len= m; siz= o; arr= a} = msg in let {Sh.bas= b; len= m; siz= o; arr= a} = msg in
let {Sh.loc= l; bas= b'; len= m'; siz= n; arr= a'} = ssg in let {Sh.loc= l; bas= b'; len= m'; siz= n; arr= a'} = ssg in
let n_o = Exp.integer n_o Typ.siz in let n_o = Term.integer n_o Typ.siz in
let com = Sh.star (Sh.seg msg) com in let com = Sh.star (Sh.seg msg) com in
let min = Sh.rem_seg msg min in let min = Sh.rem_seg msg min in
let a1', xs, zs, _ = fresh_var "a1" xs zs ~wrt:(Set.union us xs) in let a1', xs, zs, _ = fresh_var "a1" xs zs ~wrt:(Set.union us xs) in
let sub = let sub =
Sh.and_ (Exp.eq b b') Sh.and_ (Term.eq b b')
(Sh.and_ (Exp.eq m m') (Sh.and_ (Term.eq m m')
(Sh.and_ (Sh.and_
(Exp.eq (Term.eq
(Exp.concat (Term.concat
[|Exp.memory ~siz:o ~arr:a; Exp.memory ~siz:n_o ~arr:a1'|]) [| Term.memory ~siz:o ~arr:a
(Exp.memory ~siz:n ~arr:a')) ; Term.memory ~siz:n_o ~arr:a1' |])
(Term.memory ~siz:n ~arr:a'))
(Sh.star (Sh.star
(Sh.seg (Sh.seg
{ loc= Exp.add Typ.ptr l o { loc= Term.add Typ.ptr l o
; bas= b' ; bas= b'
; len= m' ; len= m'
; siz= n_o ; siz= n_o
@ -221,7 +222,7 @@ let excise_seg_sub_suffix ({us; com; min; xs; sub; zs} as goal) msg ssg l_k
msg (Sh.pp_seg_norm sub.cong) ssg pp goal] ; msg (Sh.pp_seg_norm sub.cong) ssg pp goal] ;
let {Sh.loc= k; bas= b; len= m; siz= o; arr= a} = msg in let {Sh.loc= k; bas= b; len= m; siz= o; arr= a} = msg in
let {Sh.loc= l; bas= b'; len= m'; siz= n; arr= a'} = ssg in let {Sh.loc= l; bas= b'; len= m'; siz= n; arr= a'} = ssg in
let l_k = Exp.integer l_k Typ.siz in let l_k = Term.integer l_k Typ.siz in
let a0, us, zs, wrt = fresh_var "a0" us zs ~wrt:(Set.union us xs) in let a0, us, zs, wrt = fresh_var "a0" us zs ~wrt:(Set.union us xs) in
let a1, us, zs, _ = fresh_var "a1" us zs ~wrt in let a1, us, zs, _ = fresh_var "a1" us zs ~wrt in
let com = let com =
@ -229,17 +230,17 @@ let excise_seg_sub_suffix ({us; com; min; xs; sub; zs} as goal) msg ssg l_k
in in
let min = let min =
Sh.and_ Sh.and_
(Exp.eq (Term.eq
(Exp.memory ~siz:o ~arr:a) (Term.memory ~siz:o ~arr:a)
(Exp.concat (Term.concat
[|Exp.memory ~siz:l_k ~arr:a0; Exp.memory ~siz:n ~arr:a1|])) [|Term.memory ~siz:l_k ~arr:a0; Term.memory ~siz:n ~arr:a1|]))
(Sh.star (Sh.star
(Sh.seg {loc= k; bas= b; len= m; siz= l_k; arr= a0}) (Sh.seg {loc= k; bas= b; len= m; siz= l_k; arr= a0})
(Sh.rem_seg msg min)) (Sh.rem_seg msg min))
in in
let sub = let sub =
Sh.and_ (Exp.eq b b') Sh.and_ (Term.eq b b')
(Sh.and_ (Exp.eq m m') (Sh.and_ (Exp.eq a1 a') (Sh.rem_seg ssg sub))) (Sh.and_ (Term.eq m m') (Sh.and_ (Term.eq a1 a') (Sh.rem_seg ssg sub)))
in in
{goal with us; com; min; sub; zs} {goal with us; com; min; sub; zs}
@ -264,8 +265,9 @@ let excise_seg_sub_infix ({us; com; min; xs; sub; zs} as goal) msg ssg l_k
msg (Sh.pp_seg_norm sub.cong) ssg pp goal] ; msg (Sh.pp_seg_norm sub.cong) ssg pp goal] ;
let {Sh.loc= k; bas= b; len= m; siz= o; arr= a} = msg in let {Sh.loc= k; bas= b; len= m; siz= o; arr= a} = msg in
let {Sh.loc= l; bas= b'; len= m'; siz= n; arr= a'} = ssg in let {Sh.loc= l; bas= b'; len= m'; siz= n; arr= a'} = ssg in
let l_k = Exp.integer l_k Typ.siz and ko_ln = Exp.integer ko_ln Typ.siz in let l_k = Term.integer l_k Typ.siz
let ln = Exp.add Typ.ptr l n in and ko_ln = Term.integer ko_ln Typ.siz in
let ln = Term.add Typ.ptr l n in
let a0, us, zs, wrt = fresh_var "a0" us zs ~wrt:(Set.union us xs) in let a0, us, zs, wrt = fresh_var "a0" us zs ~wrt:(Set.union us xs) in
let a1, us, zs, wrt = fresh_var "a1" us zs ~wrt in let a1, us, zs, wrt = fresh_var "a1" us zs ~wrt in
let a2, us, zs, _ = fresh_var "a2" us zs ~wrt in let a2, us, zs, _ = fresh_var "a2" us zs ~wrt in
@ -274,12 +276,12 @@ let excise_seg_sub_infix ({us; com; min; xs; sub; zs} as goal) msg ssg l_k
in in
let min = let min =
Sh.and_ Sh.and_
(Exp.eq (Term.eq
(Exp.memory ~siz:o ~arr:a) (Term.memory ~siz:o ~arr:a)
(Exp.concat (Term.concat
[| Exp.memory ~siz:l_k ~arr:a0 [| Term.memory ~siz:l_k ~arr:a0
; Exp.memory ~siz:n ~arr:a1 ; Term.memory ~siz:n ~arr:a1
; Exp.memory ~siz:ko_ln ~arr:a2 |])) ; Term.memory ~siz:ko_ln ~arr:a2 |]))
(Sh.star (Sh.star
(Sh.seg {loc= k; bas= b; len= m; siz= l_k; arr= a0}) (Sh.seg {loc= k; bas= b; len= m; siz= l_k; arr= a0})
(Sh.star (Sh.star
@ -287,8 +289,8 @@ let excise_seg_sub_infix ({us; com; min; xs; sub; zs} as goal) msg ssg l_k
(Sh.rem_seg msg min))) (Sh.rem_seg msg min)))
in in
let sub = let sub =
Sh.and_ (Exp.eq b b') Sh.and_ (Term.eq b b')
(Sh.and_ (Exp.eq m m') (Sh.and_ (Exp.eq a1 a') (Sh.rem_seg ssg sub))) (Sh.and_ (Term.eq m m') (Sh.and_ (Term.eq a1 a') (Sh.rem_seg ssg sub)))
in in
{goal with us; com; min; sub; zs} {goal with us; com; min; sub; zs}
@ -313,10 +315,10 @@ let excise_seg_min_skew ({us; com; min; xs; sub; zs} as goal) msg ssg l_k
msg (Sh.pp_seg_norm sub.cong) ssg pp goal] ; msg (Sh.pp_seg_norm sub.cong) ssg pp goal] ;
let {Sh.loc= k; bas= b; len= m; siz= o; arr= a} = msg in let {Sh.loc= k; bas= b; len= m; siz= o; arr= a} = msg in
let {Sh.loc= l; bas= b'; len= m'; siz= n; arr= a'} = ssg in let {Sh.loc= l; bas= b'; len= m'; siz= n; arr= a'} = ssg in
let l_k = Exp.integer l_k Typ.siz in let l_k = Term.integer l_k Typ.siz in
let ko_l = Exp.integer ko_l Typ.siz in let ko_l = Term.integer ko_l Typ.siz in
let ln_ko = Exp.integer ln_ko Typ.siz in let ln_ko = Term.integer ln_ko Typ.siz in
let ko = Exp.add Typ.ptr k o in let ko = Term.add Typ.ptr k o in
let a0, us, zs, wrt = fresh_var "a0" us zs ~wrt:(Set.union us xs) in let a0, us, zs, wrt = fresh_var "a0" us zs ~wrt:(Set.union us xs) in
let a1, us, zs, wrt = fresh_var "a1" us zs ~wrt in let a1, us, zs, wrt = fresh_var "a1" us zs ~wrt in
let a2', xs, zs, _ = fresh_var "a2" xs zs ~wrt in let a2', xs, zs, _ = fresh_var "a2" xs zs ~wrt in
@ -325,23 +327,23 @@ let excise_seg_min_skew ({us; com; min; xs; sub; zs} as goal) msg ssg l_k
in in
let min = let min =
Sh.and_ Sh.and_
(Exp.eq (Term.eq
(Exp.memory ~siz:o ~arr:a) (Term.memory ~siz:o ~arr:a)
(Exp.concat (Term.concat
[|Exp.memory ~siz:l_k ~arr:a0; Exp.memory ~siz:ko_l ~arr:a1|])) [|Term.memory ~siz:l_k ~arr:a0; Term.memory ~siz:ko_l ~arr:a1|]))
(Sh.star (Sh.star
(Sh.seg {loc= k; bas= b; len= m; siz= l_k; arr= a0}) (Sh.seg {loc= k; bas= b; len= m; siz= l_k; arr= a0})
(Sh.rem_seg msg min)) (Sh.rem_seg msg min))
in in
let sub = let sub =
Sh.and_ (Exp.eq b b') Sh.and_ (Term.eq b b')
(Sh.and_ (Exp.eq m m') (Sh.and_ (Term.eq m m')
(Sh.and_ (Sh.and_
(Exp.eq (Term.eq
(Exp.concat (Term.concat
[| Exp.memory ~siz:ko_l ~arr:a1 [| Term.memory ~siz:ko_l ~arr:a1
; Exp.memory ~siz:ln_ko ~arr:a2' |]) ; Term.memory ~siz:ln_ko ~arr:a2' |])
(Exp.memory ~siz:n ~arr:a')) (Term.memory ~siz:n ~arr:a'))
(Sh.star (Sh.star
(Sh.seg {loc= ko; bas= b'; len= m'; siz= ln_ko; arr= a2'}) (Sh.seg {loc= ko; bas= b'; len= m'; siz= ln_ko; arr= a2'})
(Sh.rem_seg ssg sub)))) (Sh.rem_seg ssg sub))))
@ -369,18 +371,19 @@ let excise_seg_min_suffix ({us; com; min; xs; sub; zs} as goal) msg ssg k_l
msg (Sh.pp_seg_norm sub.cong) ssg pp goal] ; msg (Sh.pp_seg_norm sub.cong) ssg pp goal] ;
let {Sh.bas= b; len= m; siz= o; arr= a} = msg in let {Sh.bas= b; len= m; siz= o; arr= a} = msg in
let {Sh.loc= l; bas= b'; len= m'; siz= n; arr= a'} = ssg in let {Sh.loc= l; bas= b'; len= m'; siz= n; arr= a'} = ssg in
let k_l = Exp.integer k_l Typ.siz in let k_l = Term.integer k_l Typ.siz in
let a0', xs, zs, _ = fresh_var "a0" xs zs ~wrt:(Set.union us xs) in let a0', xs, zs, _ = fresh_var "a0" xs zs ~wrt:(Set.union us xs) in
let com = Sh.star (Sh.seg msg) com in let com = Sh.star (Sh.seg msg) com in
let min = Sh.rem_seg msg min in let min = Sh.rem_seg msg min in
let sub = let sub =
Sh.and_ (Exp.eq b b') Sh.and_ (Term.eq b b')
(Sh.and_ (Exp.eq m m') (Sh.and_ (Term.eq m m')
(Sh.and_ (Sh.and_
(Exp.eq (Term.eq
(Exp.concat (Term.concat
[|Exp.memory ~siz:k_l ~arr:a0'; Exp.memory ~siz:o ~arr:a|]) [| Term.memory ~siz:k_l ~arr:a0'
(Exp.memory ~siz:n ~arr:a')) ; Term.memory ~siz:o ~arr:a |])
(Term.memory ~siz:n ~arr:a'))
(Sh.star (Sh.star
(Sh.seg {loc= l; bas= b'; len= m'; siz= k_l; arr= a0'}) (Sh.seg {loc= l; bas= b'; len= m'; siz= k_l; arr= a0'})
(Sh.rem_seg ssg sub)))) (Sh.rem_seg ssg sub))))
@ -409,23 +412,23 @@ let excise_seg_min_infix ({us; com; min; xs; sub; zs} as goal) msg ssg k_l
msg (Sh.pp_seg_norm sub.cong) ssg pp goal] ; msg (Sh.pp_seg_norm sub.cong) ssg pp goal] ;
let {Sh.loc= k; bas= b; len= m; siz= o; arr= a} = msg in let {Sh.loc= k; bas= b; len= m; siz= o; arr= a} = msg in
let {Sh.loc= l; bas= b'; len= m'; siz= n; arr= a'} = ssg in let {Sh.loc= l; bas= b'; len= m'; siz= n; arr= a'} = ssg in
let k_l = Exp.integer k_l Typ.siz in let k_l = Term.integer k_l Typ.siz in
let ln_ko = Exp.integer ln_ko Typ.siz in let ln_ko = Term.integer ln_ko Typ.siz in
let ko = Exp.add Typ.ptr k o in let ko = Term.add Typ.ptr k o in
let a0', xs, zs, wrt = fresh_var "a0" xs zs ~wrt:(Set.union us xs) in let a0', xs, zs, wrt = fresh_var "a0" xs zs ~wrt:(Set.union us xs) in
let a2', xs, zs, _ = fresh_var "a2" xs zs ~wrt in let a2', xs, zs, _ = fresh_var "a2" xs zs ~wrt in
let com = Sh.star (Sh.seg msg) com in let com = Sh.star (Sh.seg msg) com in
let min = Sh.rem_seg msg min in let min = Sh.rem_seg msg min in
let sub = let sub =
Sh.and_ (Exp.eq b b') Sh.and_ (Term.eq b b')
(Sh.and_ (Exp.eq m m') (Sh.and_ (Term.eq m m')
(Sh.and_ (Sh.and_
(Exp.eq (Term.eq
(Exp.concat (Term.concat
[| Exp.memory ~siz:k_l ~arr:a0' [| Term.memory ~siz:k_l ~arr:a0'
; Exp.memory ~siz:o ~arr:a ; Term.memory ~siz:o ~arr:a
; Exp.memory ~siz:ln_ko ~arr:a2' |]) ; Term.memory ~siz:ln_ko ~arr:a2' |])
(Exp.memory ~siz:n ~arr:a')) (Term.memory ~siz:n ~arr:a'))
(Sh.star (Sh.star
(Sh.seg {loc= l; bas= b'; len= m'; siz= k_l; arr= a0'}) (Sh.seg {loc= l; bas= b'; len= m'; siz= k_l; arr= a0'})
(Sh.star (Sh.star
@ -455,10 +458,10 @@ let excise_seg_sub_skew ({us; com; min; xs; sub; zs} as goal) msg ssg k_l
msg (Sh.pp_seg_norm sub.cong) ssg pp goal] ; msg (Sh.pp_seg_norm sub.cong) ssg pp goal] ;
let {Sh.loc= k; bas= b; len= m; siz= o; arr= a} = msg in let {Sh.loc= k; bas= b; len= m; siz= o; arr= a} = msg in
let {Sh.loc= l; bas= b'; len= m'; siz= n; arr= a'} = ssg in let {Sh.loc= l; bas= b'; len= m'; siz= n; arr= a'} = ssg in
let k_l = Exp.integer k_l Typ.siz in let k_l = Term.integer k_l Typ.siz in
let ln_k = Exp.integer ln_k Typ.siz in let ln_k = Term.integer ln_k Typ.siz in
let ko_ln = Exp.integer ko_ln Typ.siz in let ko_ln = Term.integer ko_ln Typ.siz in
let ln = Exp.add Typ.ptr l n in let ln = Term.add Typ.ptr l n in
let a0', xs, zs, wrt = fresh_var "a0" xs zs ~wrt:(Set.union us xs) in let a0', xs, zs, wrt = fresh_var "a0" xs zs ~wrt:(Set.union us xs) in
let a1, us, zs, wrt = fresh_var "a1" us zs ~wrt in let a1, us, zs, wrt = fresh_var "a1" us zs ~wrt in
let a2, us, zs, _ = fresh_var "a2" us zs ~wrt in let a2, us, zs, _ = fresh_var "a2" us zs ~wrt in
@ -467,23 +470,23 @@ let excise_seg_sub_skew ({us; com; min; xs; sub; zs} as goal) msg ssg k_l
in in
let min = let min =
Sh.and_ Sh.and_
(Exp.eq (Term.eq
(Exp.memory ~siz:o ~arr:a) (Term.memory ~siz:o ~arr:a)
(Exp.concat (Term.concat
[|Exp.memory ~siz:ln_k ~arr:a1; Exp.memory ~siz:ko_ln ~arr:a2|])) [|Term.memory ~siz:ln_k ~arr:a1; Term.memory ~siz:ko_ln ~arr:a2|]))
(Sh.star (Sh.star
(Sh.seg {loc= ln; bas= b; len= m; siz= ko_ln; arr= a2}) (Sh.seg {loc= ln; bas= b; len= m; siz= ko_ln; arr= a2})
(Sh.rem_seg msg min)) (Sh.rem_seg msg min))
in in
let sub = let sub =
Sh.and_ (Exp.eq b b') Sh.and_ (Term.eq b b')
(Sh.and_ (Exp.eq m m') (Sh.and_ (Term.eq m m')
(Sh.and_ (Sh.and_
(Exp.eq (Term.eq
(Exp.concat (Term.concat
[| Exp.memory ~siz:k_l ~arr:a0' [| Term.memory ~siz:k_l ~arr:a0'
; Exp.memory ~siz:ln_k ~arr:a1 |]) ; Term.memory ~siz:ln_k ~arr:a1 |])
(Exp.memory ~siz:n ~arr:a')) (Term.memory ~siz:n ~arr:a'))
(Sh.star (Sh.star
(Sh.seg {loc= l; bas= b'; len= m'; siz= k_l; arr= a0'}) (Sh.seg {loc= l; bas= b'; len= m'; siz= k_l; arr= a0'})
(Sh.rem_seg ssg sub)))) (Sh.rem_seg ssg sub))))
@ -504,13 +507,14 @@ let excise_seg ({sub} as goal) msg ssg =
|| not (Equality.entails_eq sub.cong m m') || not (Equality.entails_eq sub.cong m m')
then then
Some Some
{goal with sub= Sh.and_ (Exp.eq b b') (Sh.and_ (Exp.eq m m') goal.sub)} { goal with
sub= Sh.and_ (Term.eq b b') (Sh.and_ (Term.eq m m') goal.sub) }
else else
match[@warning "-p"] Z.sign k_l with match[@warning "-p"] Z.sign k_l with
(* k-l < 0 so k < l *) (* k-l < 0 so k < l *)
| -1 -> ( | -1 -> (
let ko = Exp.add Typ.ptr k o in let ko = Term.add Typ.ptr k o in
let ln = Exp.add Typ.ptr l n in let ln = Term.add Typ.ptr l n in
Equality.difference sub.cong ko ln Equality.difference sub.cong ko ln
>>= fun ko_ln -> >>= fun ko_ln ->
match[@warning "-p"] Z.sign ko_ln with match[@warning "-p"] Z.sign ko_ln with
@ -535,7 +539,7 @@ let excise_seg ({sub} as goal) msg ssg =
(* k-l = 0 so k = l *) (* k-l = 0 so k = l *)
| 0 -> ( | 0 -> (
match Equality.difference sub.cong o n with match Equality.difference sub.cong o n with
| None -> Some {goal with sub= Sh.and_ (Exp.eq o n) goal.sub} | None -> Some {goal with sub= Sh.and_ (Term.eq o n) goal.sub}
| Some o_n -> ( | Some o_n -> (
match[@warning "-p"] Z.sign o_n with match[@warning "-p"] Z.sign o_n with
(* o-n < 0 [k; o) (* o-n < 0 [k; o)
@ -549,8 +553,8 @@ let excise_seg ({sub} as goal) msg ssg =
| 1 -> Some (excise_seg_sub_prefix goal msg ssg o_n) ) ) | 1 -> Some (excise_seg_sub_prefix goal msg ssg o_n) ) )
(* k-l > 0 so k > l *) (* k-l > 0 so k > l *)
| 1 -> ( | 1 -> (
let ko = Exp.add Typ.ptr k o in let ko = Term.add Typ.ptr k o in
let ln = Exp.add Typ.ptr l n in let ln = Term.add Typ.ptr l n in
Equality.difference sub.cong ko ln Equality.difference sub.cong ko ln
>>= fun ko_ln -> >>= fun ko_ln ->
match[@warning "-p"] Z.sign ko_ln with match[@warning "-p"] Z.sign ko_ln with

@ -22,10 +22,10 @@ let%test_module _ =
Solver.infer_frame p (Var.Set.of_list xs) q Solver.infer_frame p (Var.Set.of_list xs) q
|> fun r -> assert (Option.is_some r) |> fun r -> assert (Option.is_some r)
let ( ! ) i = Exp.integer (Z.of_int i) Typ.siz let ( ! ) i = Term.integer (Z.of_int i) Typ.siz
let ( + ) = Exp.add Typ.ptr let ( + ) = Term.add Typ.ptr
let ( - ) = Exp.sub Typ.siz let ( - ) = Term.sub Typ.siz
let ( * ) = Exp.mul Typ.siz let ( * ) = Term.mul Typ.siz
let wrt = Var.Set.empty let wrt = Var.Set.empty
let a_, wrt = Var.fresh "a" ~wrt let a_, wrt = Var.fresh "a" ~wrt
let a2_, wrt = Var.fresh "a" ~wrt let a2_, wrt = Var.fresh "a" ~wrt
@ -36,15 +36,15 @@ let%test_module _ =
let l2_, wrt = Var.fresh "l" ~wrt let l2_, wrt = Var.fresh "l" ~wrt
let m_, wrt = Var.fresh "m" ~wrt let m_, wrt = Var.fresh "m" ~wrt
let n_, _ = Var.fresh "n" ~wrt let n_, _ = Var.fresh "n" ~wrt
let a = Exp.var a_ let a = Term.var a_
let a2 = Exp.var a2_ let a2 = Term.var a2_
let a3 = Exp.var a3_ let a3 = Term.var a3_
let b = Exp.var b_ let b = Term.var b_
let k = Exp.var k_ let k = Term.var k_
let l = Exp.var l_ let l = Term.var l_
let l2 = Exp.var l2_ let l2 = Term.var l2_
let m = Exp.var m_ let m = Term.var m_
let n = Exp.var n_ let n = Term.var n_
let%expect_test _ = let%expect_test _ =
check_frame Sh.emp [] Sh.emp ; check_frame Sh.emp [] Sh.emp ;
@ -61,7 +61,7 @@ let%test_module _ =
) infer_frame: false |}] ) infer_frame: false |}]
let%expect_test _ = let%expect_test _ =
check_frame Sh.emp [n_; m_] (Sh.and_ (Exp.eq m n) Sh.emp) ; check_frame Sh.emp [n_; m_] (Sh.and_ (Term.eq m n) Sh.emp) ;
[%expect [%expect
{| {|
( infer_frame: emp \- %m_8, %n_9 . %m_8 = %n_9 emp ( infer_frame: emp \- %m_8, %n_9 . %m_8 = %n_9 emp
@ -93,7 +93,7 @@ let%test_module _ =
let seg1 = Sh.seg {loc= l; bas= b; len= !10; siz= !10; arr= a} in let seg1 = Sh.seg {loc= l; bas= b; len= !10; siz= !10; arr= a} in
let minued = Sh.star common seg1 in let minued = Sh.star common seg1 in
let subtrahend = let subtrahend =
Sh.and_ (Exp.eq m n) Sh.and_ (Term.eq m n)
(Sh.exists (Sh.exists
(Var.Set.of_list [m_]) (Var.Set.of_list [m_])
(Sh.extend_us (Var.Set.of_list [m_]) common)) (Sh.extend_us (Var.Set.of_list [m_]) common))
@ -235,7 +235,7 @@ let%test_module _ =
let%expect_test _ = let%expect_test _ =
check_frame check_frame
(Sh.and_ (Sh.and_
Exp.(or_ (or_ (eq n !0) (eq n !1)) (eq n !2)) Term.(or_ (or_ (eq n !0) (eq n !1)) (eq n !2))
seg_split_symbolically) seg_split_symbolically)
[m_; a_] [m_; a_]
(Sh.seg {loc= l; bas= l; len= m; siz= m; arr= a}) ; (Sh.seg {loc= l; bas= l; len= m; siz= m; arr= a}) ;
@ -272,7 +272,7 @@ let%test_module _ =
(* Incompleteness: equivalent to above but using ≤ instead of *) (* Incompleteness: equivalent to above but using ≤ instead of *)
let%expect_test _ = let%expect_test _ =
infer_frame infer_frame
(Sh.and_ (Exp.le n !2) seg_split_symbolically) (Sh.and_ (Term.le n !2) seg_split_symbolically)
[m_; a_] [m_; a_]
(Sh.seg {loc= l; bas= l; len= m; siz= m; arr= a}) ; (Sh.seg {loc= l; bas= l; len= m; siz= m; arr= a}) ;
[%expect [%expect

File diff suppressed because it is too large Load Diff

@ -0,0 +1,219 @@
(*
* Copyright (c) Facebook, Inc. and its affiliates.
*
* This source code is licensed under the MIT license found in the
* LICENSE file in the root directory of this source tree.
*)
(** Terms
Pure (heap-independent) terms are complex arithmetic, bitwise-logical,
etc. operations over literal values and variables.
Terms for operations that are uninterpreted in the analyzer are
represented in curried form, where [App] is an application of a function
symbol to an argument. This is done to simplify the definition of
'subterm' and make it explicit. The specific constructor functions
indicate and check the expected arity of the function symbols. *)
type comparator_witness
type qset = (t, comparator_witness) Qset.t
and t = private
| Add of {args: qset; typ: Typ.t} (** Addition *)
| Mul of {args: qset; typ: Typ.t} (** Multiplication *)
| Splat of {byt: t; siz: t}
(** Iterated concatenation of a single byte *)
| Memory of {siz: t; arr: t} (** Size-tagged byte-array *)
| Concat of {args: t vector} (** Byte-array concatenation *)
| Var of {id: int; name: string} (** Local variable / virtual register *)
| Nondet of {msg: string}
(** Anonymous local variable with arbitrary value, representing
non-deterministic approximation of value described by [msg] *)
| Label of {parent: string; name: string}
(** Address of named code block within parent function *)
| App of {op: t; arg: t}
(** Application of function symbol to argument, curried *)
| Eq (** Equal test *)
| Dq (** Disequal test *)
| Gt (** Greater-than test *)
| Ge (** Greater-than-or-equal test *)
| Lt (** Less-than test *)
| Le (** Less-than-or-equal test *)
| Ugt (** Unsigned greater-than test *)
| Uge (** Unsigned greater-than-or-equal test *)
| Ult (** Unsigned less-than test *)
| Ule (** Unsigned less-than-or-equal test *)
| Ord (** Ordered test (neither arg is nan) *)
| Uno (** Unordered test (some arg is nan) *)
| Div (** Division *)
| Udiv (** Unsigned division *)
| Rem (** Remainder of division *)
| Urem (** Remainder of unsigned division *)
| And (** Conjunction, boolean or bitwise *)
| Or (** Disjunction, boolean or bitwise *)
| Xor (** Exclusive-or, bitwise *)
| Shl (** Shift left, bitwise *)
| Lshr (** Logical shift right, bitwise *)
| Ashr (** Arithmetic shift right, bitwise *)
| Conditional (** If-then-else *)
| Record (** Record (array / struct) constant *)
| Select (** Select an index from a record *)
| Update (** Constant record with updated index *)
| Struct_rec of {elts: t vector}
(** Struct constant that may recursively refer to itself
(transitively) from [elts]. NOTE: represented by cyclic values. *)
| Convert of {signed: bool; dst: Typ.t; src: Typ.t}
(** Convert between specified types, possibly with loss of information *)
| Integer of {data: Z.t; typ: Typ.t}
(** Integer constant, or if [typ] is a [Pointer], null pointer value
that never refers to an object *)
| Float of {data: string} (** Floating-point constant *)
[@@deriving compare, equal, hash, sexp]
val comparator : (t, comparator_witness) Comparator.t
type term = t
val pp_full : ?is_x:(term -> bool) -> t pp
val pp : t pp
val invariant : ?partial:bool -> t -> unit
(** Term.Var is re-exported as Var *)
module Var : sig
type t = private term [@@deriving compare, equal, hash, sexp]
type var = t
include Comparator.S with type t := t
module Set : sig
type t = (var, comparator_witness) Set.t
[@@deriving compare, equal, sexp]
val pp_full : ?is_x:(term -> bool) -> t pp
val pp : t pp
val empty : t
val of_option : var option -> t
val of_list : var list -> t
val of_vector : var vector -> t
val of_regs : Reg.Set.t -> t
end
module Map : sig
type 'a t = (var, 'a, comparator_witness) Map.t
[@@deriving compare, equal, sexp]
val empty : 'a t
end
val pp : t pp
val pp_demangled : t pp
include Invariant.S with type t := t
val of_reg : Reg.t -> t
val of_term : term -> t option
val program : string -> t
val fresh : string -> wrt:Set.t -> t * Set.t
val id : t -> int
val name : t -> string
module Subst : sig
type t [@@deriving compare, equal, sexp]
val pp : t pp
val empty : t
val freshen : Set.t -> wrt:Set.t -> t
val extend : t -> replace:var -> with_:var -> t
val invert : t -> t
val exclude : t -> Set.t -> t
val restrict : t -> Set.t -> t
val is_empty : t -> bool
val domain : t -> Set.t
val range : t -> Set.t
val apply_set : t -> Set.t -> Set.t
val close_set : t -> Set.t -> Set.t
end
end
(** Construct *)
val of_exp : Exp.t -> t
val var : Var.t -> t
val nondet : string -> t
val label : parent:string -> name:string -> t
val null : t
val splat : byt:t -> siz:t -> t
val memory : siz:t -> arr:t -> t
val concat : t array -> t
val bool : bool -> t
val integer : Z.t -> Typ.t -> t
val rational : Q.t -> Typ.t -> t
val float : string -> t
val eq : t -> t -> t
val dq : t -> t -> t
val gt : t -> t -> t
val ge : t -> t -> t
val lt : t -> t -> t
val le : t -> t -> t
val ugt : t -> t -> t
val uge : t -> t -> t
val ult : t -> t -> t
val ule : t -> t -> t
val ord : t -> t -> t
val uno : t -> t -> t
val neg : Typ.t -> t -> t
val add : Typ.t -> t -> t -> t
val sub : Typ.t -> t -> t -> t
val mul : Typ.t -> t -> t -> t
val div : t -> t -> t
val udiv : t -> t -> t
val rem : t -> t -> t
val urem : t -> t -> t
val and_ : t -> t -> t
val or_ : t -> t -> t
val xor : t -> t -> t
val not_ : Typ.t -> t -> t
val shl : t -> t -> t
val lshr : t -> t -> t
val ashr : t -> t -> t
val conditional : cnd:t -> thn:t -> els:t -> t
val record : t list -> t
val select : rcd:t -> idx:t -> t
val update : rcd:t -> elt:t -> idx:t -> t
val struct_rec :
(module Hashtbl.Key with type t = 'id)
-> (id:'id -> t lazy_t vector -> t) Staged.t
(** [struct_rec Id id element_thunks] constructs a possibly-cyclic [Struct]
value. Cycles are detected using [Id]. The caller of [struct_rec Id]
must ensure that a single unstaging of [struct_rec Id] is used for each
complete cyclic value. Also, the caller must ensure that recursive calls
to [struct_rec Id] provide [id] values that uniquely identify at least
one point on each cycle. Failure to obey these requirements will lead to
stack overflow. *)
val convert : ?signed:bool -> dst:Typ.t -> src:Typ.t -> t -> t
val size_of : Typ.t -> t option
(** Access *)
val iter : t -> f:(t -> unit) -> unit
val fold_vars : t -> init:'a -> f:('a -> Var.t -> 'a) -> 'a
val fold_terms : t -> init:'a -> f:('a -> t -> 'a) -> 'a
val fold : t -> init:'a -> f:(t -> 'a -> 'a) -> 'a
(** Transform *)
val map : t -> f:(t -> t) -> t
val rename : Var.Subst.t -> t -> t
(** Query *)
val fv : t -> Var.Set.t
val is_true : t -> bool
val is_false : t -> bool
val typ : t -> Typ.t option
val classify : t -> [> `Atomic | `Interpreted | `Simplified | `Uninterpreted]
val solve : t -> t -> (t, t, comparator_witness) Map.t option

@ -9,48 +9,50 @@ let%test_module _ =
( module struct ( module struct
(* let () = Trace.init ~margin:68 ~config:all () *) (* let () = Trace.init ~margin:68 ~config:all () *)
let () = Trace.init ~margin:68 ~config:none () let () = Trace.init ~margin:68 ~config:none ()
let pp = Format.printf "@\n%a@." Exp.pp let pp = Format.printf "@\n%a@." Term.pp
let char = Typ.integer ~bits:8 let char = Typ.integer ~bits:8
let ( ! ) i = Exp.integer (Z.of_int i) char let ( ! ) i = Term.integer (Z.of_int i) char
let ( + ) = Exp.add char let ( + ) = Term.add char
let ( - ) = Exp.sub char let ( - ) = Term.sub char
let ( * ) = Exp.mul char let ( * ) = Term.mul char
let ( = ) = Exp.eq let ( = ) = Term.eq
let ( != ) = Exp.dq let ( != ) = Term.dq
let ( > ) = Exp.gt let ( > ) = Term.gt
let ( >= ) = Exp.ge let ( >= ) = Term.ge
let ( < ) = Exp.lt let ( < ) = Term.lt
let ( <= ) = Exp.le let ( <= ) = Term.le
let ( && ) = Exp.and_ let ( && ) = Term.and_
let ( || ) = Exp.or_ let ( || ) = Term.or_
let ( ~~ ) = Exp.not_ Typ.bool let ( ~~ ) = Term.not_ Typ.bool
let wrt = Var.Set.empty let wrt = Var.Set.empty
let y_, wrt = Var.fresh "y" ~wrt let y_, wrt = Var.fresh "y" ~wrt
let z_, _ = Var.fresh "z" ~wrt let z_, _ = Var.fresh "z" ~wrt
let y = Exp.var y_ let y = Term.var y_
let z = Exp.var z_ let z = Term.var z_
let%test "booleans distinct" = let%test "booleans distinct" =
Exp.is_false Term.is_false
(Exp.eq (Term.eq
(Exp.integer Z.minus_one Typ.bool) (Term.integer Z.minus_one Typ.bool)
(Exp.integer Z.zero Typ.bool)) (Term.integer Z.zero Typ.bool))
let%test "unsigned booleans distinct" = let%test "unsigned booleans distinct" =
Exp.is_false Term.is_false
(Exp.eq (Exp.integer Z.one Typ.bool) (Exp.integer Z.zero Typ.bool)) (Term.eq
(Term.integer Z.one Typ.bool)
(Term.integer Z.zero Typ.bool))
let%test "boolean overflow" = let%test "boolean overflow" =
Exp.is_true Term.is_true
(Exp.eq (Term.eq
(Exp.integer Z.minus_one Typ.bool) (Term.integer Z.minus_one Typ.bool)
(Exp.integer Z.one Typ.bool)) (Term.integer Z.one Typ.bool))
let%test "unsigned boolean overflow" = let%test "unsigned boolean overflow" =
Exp.is_true Term.is_true
(Exp.uge (Term.uge
(Exp.integer Z.minus_one Typ.bool) (Term.integer Z.minus_one Typ.bool)
(Exp.integer Z.one Typ.bool)) (Term.integer Z.one Typ.bool))
let%expect_test _ = let%expect_test _ =
pp (!42 + !13) ; pp (!42 + !13) ;
@ -176,19 +178,19 @@ let%test_module _ =
[%expect {| 0 |}] [%expect {| 0 |}]
let%expect_test _ = let%expect_test _ =
pp (!3 * y = z = Exp.bool true) ; pp (!3 * y = z = Term.bool true) ;
[%expect {| ((3 × %y_1) = %z_2) |}] [%expect {| ((3 × %y_1) = %z_2) |}]
let%expect_test _ = let%expect_test _ =
pp (Exp.bool true = (!3 * y = z)) ; pp (Term.bool true = (!3 * y = z)) ;
[%expect {| ((3 × %y_1) = %z_2) |}] [%expect {| ((3 × %y_1) = %z_2) |}]
let%expect_test _ = let%expect_test _ =
pp (!3 * y = z = Exp.bool false) ; pp (!3 * y = z = Term.bool false) ;
[%expect {| ((3 × %y_1) %z_2) |}] [%expect {| ((3 × %y_1) %z_2) |}]
let%expect_test _ = let%expect_test _ =
pp (Exp.bool false = (!3 * y = z)) ; pp (Term.bool false = (!3 * y = z)) ;
[%expect {| ((3 × %y_1) %z_2) |}] [%expect {| ((3 × %y_1) %z_2) |}]
let%expect_test _ = let%expect_test _ =
@ -208,11 +210,11 @@ let%test_module _ =
[%expect {| ((-3 × %y_1 + 4) = %y_1) |}] [%expect {| ((-3 × %y_1 + 4) = %y_1) |}]
let%expect_test _ = let%expect_test _ =
pp (Exp.sub Typ.bool (Exp.bool true) (z = !4)) ; pp (Term.sub Typ.bool (Term.bool true) (z = !4)) ;
[%expect {| (-1 × (%z_2 = 4) + -1) |}] [%expect {| (-1 × (%z_2 = 4) + -1) |}]
let%expect_test _ = let%expect_test _ =
pp (Exp.add Typ.bool (Exp.bool true) (z = !4) = (z = !4)) ; pp (Term.add Typ.bool (Term.bool true) (z = !4) = (z = !4)) ;
[%expect {| (((%z_2 = 4) + -1) = (%z_2 = 4)) |}] [%expect {| (((%z_2 = 4) + -1) = (%z_2 = 4)) |}]
let%expect_test _ = let%expect_test _ =
@ -244,9 +246,9 @@ let%test_module _ =
[%expect {| ((%y_1 < 2) && (%z_2 3)) |}] [%expect {| ((%y_1 < 2) && (%z_2 3)) |}]
let%expect_test _ = let%expect_test _ =
pp Exp.(eq z null) ; pp Term.(eq z null) ;
pp Exp.(eq null z) ; pp Term.(eq null z) ;
pp Exp.(dq (eq null z) (bool false)) ; pp Term.(dq (eq null z) (bool false)) ;
[%expect [%expect
{| {|
(%z_2 = null) (%z_2 = null)

@ -7,4 +7,4 @@
(** Variables *) (** Variables *)
include Exp.Var include Term.Var

@ -7,4 +7,4 @@
(** Variables *) (** Variables *)
include module type of Exp.Var include module type of Term.Var
Loading…
Cancel
Save