pghs975uc
/
infer_clone
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

[sledge] Eliminate SSA

Browse Source 
Summary:
While SSA can be useful for code transformation purposes, it offers
little for semantic static analyses. Essentially, such analyses
explore the dynamic semantics of code, and the *static* single
assignment property does not buy much. For example, once an execution
visits a loop body that assigns a variable, there are multiple
assignments that the analysis must deal with. This leads to the need
to treat blocks as if they assign all their local variables, renaming
to avoid name clashes a la Floyd's assignment axiom. That is fine, but
it makes it much more involved to implement a version that is
economical with respect to renaming only when necessary. Additionally
the scoping constraints of SSA are cumbersome and significantly
complicate interprocedural analysis (where there is a long history of
incorrect proof rules for procedures, and SSA pushes the
interprocedural analysis away from being able to use known-good
ones). So this diff changes Llair from a functional SSA form to a
traditional imperative language.

Reviewed By: jvillard

Differential Revision: D16905898

fbshipit-source-id: 0fd835220
master
Josh Berdine 5 years ago committed by Facebook Github Bot
parent b6eab89504
commit 3f8d5ace6e
16 changed files with 463 additions and 612 deletions
Show Stats Download Patch File Download Diff File

193
sledge/src/control.ml
Unescape View File

@ -18,14 +18,7 @@ module Stack : sig
val empty : t val empty : t
val push_call : val push_call :
Llair.block Llair.func Llair.call -> bound:int -> Domain.from_call -> t -> t option
-> retreating:bool
-> bound:int
-> return:Llair.jump
-> Domain.from_call
-> ?throw:Llair.jump
-> t
-> t option
val pop_return : t -> (Domain.from_call * Llair.jump * t) option val pop_return : t -> (Domain.from_call * Llair.jump * t) option
@ -37,8 +30,7 @@ module Stack : sig
end = struct end = struct
type t = type t =
| Return of | Return of
{ retreating: bool { recursive: bool (** return from a possibly-recursive call *)
(** return from a call not known to be nonrecursive *)
; dst: Llair.Jump.t ; dst: Llair.Jump.t
; params: Var.t list ; params: Var.t list
; locals: Var.Set.t ; locals: Var.Set.t
@ -59,8 +51,8 @@ end = struct
if x == y then 0 if x == y then 0
else else
match (x, y) with match (x, y) with
| Return {retreating= true; stk= x}, y | Return {recursive= true; stk= x}, y
|x, Return {retreating= true; stk= y} -> |x, Return {recursive= true; stk= y} ->
compare_as_inlined_location x y compare_as_inlined_location x y
| Return {dst= j; stk= x}, Return {dst= k; stk= y} -> ( | Return {dst= j; stk= x}, Return {dst= k; stk= y} -> (
match Llair.Jump.compare j k with match Llair.Jump.compare j k with
@ -77,10 +69,10 @@ end = struct
| Empty, Empty -> 0 | Empty, Empty -> 0
let rec print_abbrev fs = function let rec print_abbrev fs = function
| Return {retreating= false; stk= s} -> | Return {recursive= false; stk= s} ->
print_abbrev fs s ; print_abbrev fs s ;
Format.pp_print_char fs 'R' Format.pp_print_char fs 'R'
| Return {retreating= true; stk= s} -> | Return {recursive= true; stk= s} ->
print_abbrev fs s ; print_abbrev fs s ;
Format.pp_print_string fs "R↑" Format.pp_print_string fs "R↑"
| Throw (_, s) -> | Throw (_, s) ->
@ -97,16 +89,16 @@ end = struct
let empty = Empty |> check invariant let empty = Empty |> check invariant
let push_return ~retreating dst params locals from_call stk = let push_return Llair.{callee= {params; locals}; return; recursive}
Return {retreating; dst; params; locals; from_call; stk} from_call stk =
Return {recursive; dst= return; params; locals; from_call; stk}
|> check invariant |> check invariant
let push_throw jmp stk = let push_throw jmp stk =
(match jmp with None -> stk | Some jmp -> Throw (jmp, stk)) (match jmp with None -> stk | Some jmp -> Throw (jmp, stk))
|> check invariant |> check invariant
let push_call (entry : Llair.block) ~retreating ~bound ~return from_call let push_call (Llair.{return; throw} as call) ~bound from_call stk =
?throw stk =
[%Trace.call fun {pf} -> pf "%a" print_abbrev stk] [%Trace.call fun {pf} -> pf "%a" print_abbrev stk]
; ;
let rec count_f_in_stack acc f = function let rec count_f_in_stack acc f = function
@ -118,11 +110,7 @@ end = struct
in in
let n = count_f_in_stack 0 return stk in let n = count_f_in_stack 0 return stk in
( if n > bound then None ( if n > bound then None
else else Some (push_throw throw (push_return call from_call stk)) )
Some
(push_throw throw
(push_return ~retreating return entry.params entry.parent.locals
from_call stk)) )
|> |>
[%Trace.retn fun {pf} _ -> [%Trace.retn fun {pf} _ ->
pf "%d of %a on stack" n Llair.Jump.pp return] pf "%d of %a on stack" n Llair.Jump.pp return]
@ -246,55 +234,52 @@ end = struct
| None -> [%Trace.info "queue empty"] ; () | None -> [%Trace.info "queue empty"] ; ()
end end
let exec_goto stk state block ({dst; retreating} : Llair.jump) = 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 exec_jump ?temps stk state block ({dst; args} as jmp : Llair.jump) =
let state = Domain.jump args dst.params ?temps state in
exec_goto stk state block jmp
let summary_table = Hashtbl.create (module Var) let summary_table = Hashtbl.create (module Var)
let exec_call opts stk state block ({dst; args; retreating} : Llair.jump) let exec_call opts stk state block call globals =
(return : Llair.jump) throw globals = let Llair.{callee; args; areturn; return; recursive} = call in
let Llair.{name; params; freturn; locals; entry} = callee in
[%Trace.call fun {pf} -> [%Trace.call fun {pf} ->
pf "%a from %a" Var.pp dst.parent.name.var Var.pp pf "%a from %a" Var.pp name.var Var.pp return.dst.parent.name.var]
return.dst.parent.name.var]
; ;
let dnf_states = let dnf_states =
if opts.function_summaries then Domain.dnf state else [state] if opts.function_summaries then Domain.dnf state else [state]
in in
let locals = dst.parent.locals in let domain_call =
let domain_call = Domain.call args dst.params locals globals in Domain.call args areturn params (Set.add_option freturn locals) globals
in
List.fold ~init:Work.skip dnf_states ~f:(fun acc state -> List.fold ~init:Work.skip dnf_states ~f:(fun acc state ->
let maybe_summary_post = match
if opts.function_summaries then if not opts.function_summaries then None
let state = fst (domain_call ~summaries:false state) in else
Hashtbl.find summary_table dst.parent.name.var let maybe_summary_post =
>>= List.find_map ~f:(Domain.apply_summary state) let state = fst (domain_call ~summaries:false state) in
else None Hashtbl.find summary_table name.var
in >>= List.find_map ~f:(Domain.apply_summary state)
[%Trace.info in
"Maybe summary post: %a" [%Trace.info
(Option.pp "%a" Domain.pp) "Maybe summary post: %a"
maybe_summary_post] ; (Option.pp "%a" Domain.pp)
match maybe_summary_post with maybe_summary_post] ;
maybe_summary_post
with
| None -> | None ->
let state, from_call = let state, from_call =
domain_call ~summaries:opts.function_summaries state domain_call ~summaries:opts.function_summaries state
in in
Work.seq acc Work.seq acc
( match ( match Stack.push_call call ~bound:opts.bound from_call stk with
Stack.push_call ~bound:opts.bound dst ~retreating ~return | Some stk ->
from_call ?throw stk Work.add stk ~prev:block ~retreating:recursive state entry
with
| Some stk -> Work.add stk ~prev:block ~retreating state dst
| None -> Work.skip ) | None -> Work.skip )
| Some post -> Work.seq acc (exec_goto stk post block return) ) | Some post -> Work.seq acc (exec_jump stk post block return) )
|> |>
[%Trace.retn fun {pf} _ -> pf ""] [%Trace.retn fun {pf} _ -> pf ""]
let pp_st _ = let pp_st () =
[%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 ->
@ -303,88 +288,72 @@ let pp_st _ =
data ) )] data ) )]
let exec_return ~opts stk pre_state (block : Llair.block) exp globals = let exec_return ~opts stk pre_state (block : Llair.block) exp globals =
[%Trace.call fun {pf} -> pf "from %a" Var.pp block.parent.name.var] let Llair.{name; params; freturn; locals} = block.parent in
[%Trace.call fun {pf} -> pf "from %a" Var.pp name.var]
; ;
( match Stack.pop_return stk with ( match Stack.pop_return stk with
| Some (from_call, retn_site, stk) -> | Some (from_call, retn_site, stk) ->
let freturn = block.parent.freturn in
let exit_state = let exit_state =
match (freturn, exp) with match (freturn, exp) with
| Some freturn, Some return_val -> | Some freturn, Some return_val ->
Domain.exec_return pre_state freturn return_val Domain.exec_move pre_state freturn return_val
| None, None -> pre_state | None, None -> pre_state
| _ -> violates Llair.Func.invariant block.parent | _ -> violates Llair.Func.invariant block.parent
in in
let exit_state = let post_state = Domain.post locals from_call exit_state in
let post_state =
if opts.function_summaries then ( if opts.function_summaries then (
let globals = let globals =
Var.Set.of_vector Var.Set.of_vector
(Vector.map globals ~f:(fun (g : Global.t) -> g.var)) (Vector.map globals ~f:(fun (g : Global.t) -> g.var))
in in
let function_summary, exit_state = let function_summary, post_state =
Domain.create_summary ~locals:block.parent.locals exit_state Domain.create_summary ~locals post_state
~formals: ~formals:(Set.union (Var.Set.of_list params) globals)
(Set.union
(Var.Set.of_list block.parent.entry.params)
globals)
in in
Hashtbl.add_multi summary_table ~key:block.parent.name.var Hashtbl.add_multi summary_table ~key:name.var
~data:function_summary ; ~data:function_summary ;
pp_st () ; pp_st () ;
exit_state ) post_state )
else exit_state else post_state
in in
let post_state = let retn_state = Domain.retn params freturn from_call post_state in
Domain.post block.parent.locals from_call exit_state exec_jump stk retn_state block retn_site
in
let retn_state =
Domain.retn block.parent.entry.params from_call post_state
in
exec_jump stk retn_state block
~temps:(Option.fold ~f:Set.add freturn ~init:Var.Set.empty)
( match freturn with
| Some freturn -> Llair.Jump.push_arg (Exp.var freturn) retn_site
| None -> retn_site )
| None -> Work.skip ) | None -> Work.skip )
|> |>
[%Trace.retn fun {pf} _ -> pf ""] [%Trace.retn fun {pf} _ -> pf ""]
let exec_throw stk pre_state (block : Llair.block) exc = let exec_throw stk pre_state (block : Llair.block) exc =
[%Trace.call fun {pf} -> pf "from %a" Var.pp block.parent.name.var] let func = block.parent in
[%Trace.call fun {pf} -> pf "from %a" Var.pp func.name.var]
; ;
let unwind params scope from_call state = let unwind params scope from_call state =
Domain.retn params from_call (Domain.post scope from_call state) Domain.retn params (Some func.fthrow) from_call
(Domain.post scope from_call state)
in in
( match Stack.pop_throw stk ~unwind ~init:pre_state with ( match Stack.pop_throw stk ~unwind ~init:pre_state with
| Some (from_call, retn_site, stk, unwind_state) -> | Some (from_call, retn_site, stk, unwind_state) ->
let fthrow = block.parent.fthrow in let fthrow = func.fthrow in
let exit_state = Domain.exec_return unwind_state fthrow exc in let exit_state = Domain.exec_move unwind_state fthrow exc in
let post_state = let post_state = Domain.post func.locals from_call exit_state in
Domain.post block.parent.locals from_call exit_state
in
let retn_state = let retn_state =
Domain.retn block.parent.entry.params from_call post_state Domain.retn func.params func.freturn from_call post_state
in in
exec_jump stk retn_state block exec_jump stk retn_state block retn_site
~temps:(Set.add Var.Set.empty fthrow)
(Llair.Jump.push_arg (Exp.var fthrow) retn_site)
| None -> Work.skip ) | None -> Work.skip )
|> |>
[%Trace.retn fun {pf} _ -> pf ""] [%Trace.retn fun {pf} _ -> pf ""]
let exec_skip_func : let exec_skip_func :
Stack.t -> Domain.t -> Llair.block -> Llair.jump -> Work.x = Stack.t
fun stk state block ({dst; args} as return) -> -> Domain.t
-> Llair.block
-> Var.t option
-> Llair.jump
-> Work.x =
fun stk state block areturn return ->
Report.unknown_call block.term ; Report.unknown_call block.term ;
let return = let state = Option.fold ~f:Domain.exec_kill ~init:state areturn in
if List.is_empty dst.params then return
else
let args =
List.fold_right dst.params ~init:args ~f:(fun param args ->
Exp.nondet (Var.name param) :: args )
in
{return with args}
in
exec_jump stk state block return exec_jump stk state block return
let exec_term : let exec_term :
@ -417,32 +386,30 @@ let exec_term :
with with
| Some state -> exec_jump stk state block jump |> Work.seq x | Some state -> exec_jump stk state block jump |> Work.seq x
| None -> x ) | None -> x )
| Call {call= {dst; args; retreating}; return; throw} -> ( | Call ({callee; args; areturn; return} as call) -> (
match match
let lookup name = let lookup name =
Option.to_list (Llair.Func.find pgm.functions name) Option.to_list (Llair.Func.find pgm.functions name)
in in
Domain.resolve_callee lookup dst state Domain.resolve_callee lookup callee state
with with
| [] -> exec_skip_func stk state block return | [] -> exec_skip_func stk state block areturn return
| callees -> | callees ->
List.fold callees ~init:Work.skip ~f:(fun x callee -> List.fold callees ~init:Work.skip ~f:(fun x callee ->
( match ( match
Domain.exec_intrinsic ~skip_throw:opts.skip_throw state Domain.exec_intrinsic ~skip_throw:opts.skip_throw state
(List.hd return.dst.params) areturn callee.name.var args
callee.name.var args
with with
| Some (Error ()) -> | Some (Error ()) ->
Report.invalid_access_term (Domain.project state) block.term ; Report.invalid_access_term (Domain.project state) block.term ;
Work.skip Work.skip
| Some (Ok state) when Domain.is_false state -> Work.skip | Some (Ok state) when Domain.is_false state -> Work.skip
| Some (Ok state) -> exec_goto stk state block return | Some (Ok state) -> exec_jump stk state block return
| None when Llair.Func.is_undefined callee -> | None when Llair.Func.is_undefined callee ->
exec_skip_func stk state block return exec_skip_func stk state block areturn return
| None -> | None ->
exec_call opts stk state block exec_call opts stk state block {call with callee}
{dst= callee.entry; args; retreating} pgm.globals )
return throw pgm.globals )
|> Work.seq x ) ) |> Work.seq x ) )
| Return {exp} -> exec_return ~opts stk state block exp pgm.globals | Return {exp} -> exec_return ~opts stk state block exp pgm.globals
| Throw {exc} -> | Throw {exc} ->
@ -471,13 +438,13 @@ let harness : exec_opts -> Llair.t -> (int -> Work.t) option =
List.find_map entry_points ~f:(fun name -> List.find_map entry_points ~f:(fun name ->
Llair.Func.find pgm.functions (Var.program name) ) Llair.Func.find pgm.functions (Var.program name) )
|> function |> function
| Some {locals; entry= {params= []} as block} -> | Some {locals; params= []; entry} ->
Some Some
(Work.init (Work.init
(fst (fst
(Domain.call ~summaries:opts.function_summaries [] [] locals (Domain.call ~summaries:opts.function_summaries [] None []
pgm.globals (Domain.init pgm.globals))) locals pgm.globals (Domain.init pgm.globals)))
block) entry)
| _ -> None | _ -> None
let exec_pgm : exec_opts -> Llair.t -> unit = let exec_pgm : exec_opts -> Llair.t -> unit =

1
sledge/src/import/import.ml
Unescape View File

@ -264,6 +264,7 @@ module Set = struct
let equal_m__t (module Elt : Compare_m) = equal let equal_m__t (module Elt : Compare_m) = equal
let pp pp_elt fs x = List.pp ",@ " pp_elt fs (to_list x) let pp pp_elt fs x = List.pp ",@ " pp_elt fs (to_list x)
let disjoint x y = is_empty (inter x y) let disjoint x y = is_empty (inter x y)
let add_option yo x = Option.fold ~f:add ~init:x yo
let add_list ys x = List.fold ~f:add ~init:x ys let add_list ys x = List.fold ~f:add ~init:x ys
let diff_inter_diff x y = (diff x y, inter x y, diff y x) let diff_inter_diff x y = (diff x y, inter x y, diff y x)
let inter_diff x y = (inter x y, diff y x) let inter_diff x y = (inter x y, diff y x)

1
sledge/src/import/import.mli
Unescape View File

@ -212,6 +212,7 @@ module Set : sig
val pp : 'e pp -> ('e, 'c) t pp val pp : 'e pp -> ('e, 'c) t pp
val disjoint : ('e, 'c) t -> ('e, 'c) t -> bool val disjoint : ('e, 'c) t -> ('e, 'c) t -> bool
val add_option : 'e option -> ('e, 'c) t -> ('e, 'c) t
val add_list : 'e list -> ('e, 'c) t -> ('e, 'c) t val add_list : 'e list -> ('e, 'c) t -> ('e, 'c) t
val diff_inter_diff : val diff_inter_diff :

1
sledge/src/llair/exp.ml
Unescape View File

@ -520,6 +520,7 @@ module Var = struct
let pp_full ?is_x vs = Set.pp (pp_full ?is_x) vs let pp_full ?is_x vs = Set.pp (pp_full ?is_x) vs
let pp = pp_full ?is_x:None let pp = pp_full ?is_x:None
let empty = Set.empty (module T) let empty = Set.empty (module T)
let of_option = Option.fold ~f:Set.add ~init:empty
let of_list = Set.of_list (module T) let of_list = Set.of_list (module T)
let of_vector = Set.of_vector (module T) let of_vector = Set.of_vector (module T)
end end

1
sledge/src/llair/exp.mli
Unescape View File

@ -99,6 +99,7 @@ module Var : sig
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_list : var list -> t val of_list : var list -> t
val of_vector : var vector -> t val of_vector : var vector -> t
end end

371
sledge/src/llair/frontend.ml
Unescape View File

@ -675,150 +675,49 @@ let landingpad_typs : x -> Llvm.llvalue -> Typ.t * Typ.t * Llvm.lltype =
let cxa_exception = Llvm.struct_type llcontext [|tip; dtor|] in let cxa_exception = Llvm.struct_type llcontext [|tip; dtor|] in
(i32, xlate_type x tip, cxa_exception) (i32, xlate_type x tip, cxa_exception)
(** construct the argument of a landingpad block, mainly fix the encoding (** Translate a control transfer from instruction [instr] to block [dst] to
scheme for landingpad instruction name to block arg name *) a jump, if necessary by extending [blocks] with a trampoline containing
let landingpad_arg : Llvm.llvalue -> Var.t = the PHIs of [dst] translated to a move. *)
fun instr -> Var.program (find_name instr ^ ".exc") let xlate_jump :
x
(** [rev_map_phis ~f blk] returns [(retn_arg, rev_args, pos)] by rev_mapping -> ?reg_exps:(Var.var * Exp.t) list
over the prefix of [PHI] instructions at the beginning of [blk]. -> Llvm.llvalue
[retn_arg], if any, is [f] applied to the [PHI] instruction which takes
the return value of every [Invoke] predecessor of [blk]. [rev_args] is
the result of applying [f] to each of the other [PHI] instructions.
[pos] is the instruction iterator position before the first non-[PHI]
instruction of [blk]. *)
let rev_map_phis :
f:(Llvm.llvalue -> 'a)
-> Llvm.llbasicblock -> Llvm.llbasicblock
-> 'a option * 'a list * _ Llvm.llpos = -> Loc.t
fun ~f blk -> -> Llair.block list
let rec block_args_ found_invoke_pred retn_arg rev_args pos = -> Llair.jump * Llair.block list =
match (pos : _ Llvm.llpos) with fun x ?(reg_exps = []) instr dst loc blocks ->
| Before instr -> ( let src = Llvm.instr_parent instr in
match Llvm.instr_opcode instr with let rec xlate_jump_ reg_exps (pos : _ Llvm.llpos) =
match pos with
| Before dst_instr -> (
match Llvm.instr_opcode dst_instr with
| PHI -> | PHI ->
(* [has_invoke_pred] holds if some value selected by this PHI is let reg_exp =
the return value of an [invoke] instr. [is_retn_arg] holds if List.find_map_exn (Llvm.incoming dst_instr)
for each predecessor terminated by an invoke instr, this PHI ~f:(fun (arg, pred) ->
instr takes the value of the invoke's return value. *) if Poly.equal pred src then
let has_invoke_pred, is_retn_arg = Some (xlate_name dst_instr, xlate_value x arg)
List.fold (Llvm.incoming instr) ~init:(false, true) else None )
~f:(fun (has_invoke_pred, is_retn_arg) (arg, pred) ->
match Llvm.block_terminator pred with
| Some instr -> (
match Llvm.instr_opcode instr with
| Invoke when Poly.equal arg instr -> (true, is_retn_arg)
| Invoke -> (has_invoke_pred, false)
| _ -> (has_invoke_pred, is_retn_arg) )
| None -> fail "rev_map_phis: %a" pp_llblock blk () )
in
if found_invoke_pred && has_invoke_pred then
(* Supporting multiple PHI instructions that take the return
values of invoke instructions will require adding trampolines
for the invoke instructions to return to, that each reorder
arguments and invoke the translation of this block. *)
todo "multiple PHI instructions taking invoke return values: %a"
pp_llblock blk () ;
let retn_arg, rev_args =
if has_invoke_pred && is_retn_arg then (Some (f instr), rev_args)
else (None, f instr :: rev_args)
in in
block_args_ has_invoke_pred retn_arg rev_args xlate_jump_ (reg_exp :: reg_exps) (Llvm.instr_succ dst_instr)
(Llvm.instr_succ instr) | _ -> reg_exps )
| LandingPad when Option.is_some retn_arg -> | At_end blk -> fail "xlate_jump: %a" pp_llblock blk ()
(* Supporting returning and throwing to the same block, with
different arguments, will require adding trampolines. *)
todo
"return and throw to the same block with different arguments: %a"
pp_llblock blk ()
| _ -> (retn_arg, rev_args, pos) )
| At_end blk -> fail "rev_map_phis: %a" pp_llblock blk ()
in in
block_args_ false None [] (Llvm.instr_begin blk) let jmp = Llair.Jump.mk (label_of_block dst) in
match xlate_jump_ reg_exps (Llvm.instr_begin dst) with
(** [trampoline_args jump_instr dest_block] is the actual arguments to which | [] -> (jmp, blocks)
the translation of [dest_block] should be partially-applied, to yield a | reg_exps ->
trampoline accepting the return parameter of the block and then jumping let mov =
with all the args. *) Llair.Inst.move ~reg_exps:(Vector.of_list_rev reg_exps) ~loc
let trampoline_args : x -> Llvm.llvalue -> Llvm.llbasicblock -> Exp.t list =
fun x jmp dst ->
let src = Llvm.instr_parent jmp in
rev_map_phis dst ~f:(fun instr ->
List.find_map_exn (Llvm.incoming instr) ~f:(fun (arg, pred) ->
if Poly.equal pred src then Some (xlate_value x arg) else None )
)
|> snd3
(** [unique_pred blk] is the unique predecessor of [blk], or [None] if there
are 0 or >1 predecessors. *)
let unique_pred : Llvm.llbasicblock -> Llvm.llvalue option =
fun blk ->
match Llvm.use_begin (Llvm.value_of_block blk) with
| Some use -> (
match Llvm.use_succ use with
| None -> Some (Llvm.user use)
| Some _ -> None )
| None -> None
(** [return_formal_is_used instr] holds if the return value of [instr] is
used anywhere. *)
let return_formal_is_used : Llvm.llvalue -> bool =
fun instr -> Option.is_some (Llvm.use_begin instr)
(** [need_return_trampoline instr blk] holds when the return formal of
[instr] is used, but the returned to block [blk] does not take it as an
argument (e.g. if it has multiple predecessors and no PHI node). *)
let need_return_trampoline : Llvm.llvalue -> Llvm.llbasicblock -> bool =
fun instr blk ->
Option.is_none (fst3 (rev_map_phis blk ~f:Fn.id))
&& Option.is_none (unique_pred blk)
&& return_formal_is_used instr
(** [unique_used_invoke_pred blk] is the unique predecessor of [blk], if it
is an [Invoke] instruction, whose return value is used. *)
let unique_used_invoke_pred : Llvm.llbasicblock -> 'a option =
fun blk ->
let is_invoke i = Poly.equal (Llvm.instr_opcode i) Invoke in
match unique_pred blk with
| Some instr when is_invoke instr && return_formal_is_used instr ->
Some instr
| _ -> None
(** formal parameters accepted by a block *)
let block_formals : Llvm.llbasicblock -> Var.t list * _ Llvm.llpos =
fun blk ->
let retn_arg, rev_args, pos = rev_map_phis blk ~f:xlate_name in
match pos with
| Before instr ->
let instr_arg =
match Llvm.instr_opcode instr with
| LandingPad ->
assert (Option.is_none retn_arg (* ensured by rev_map_phis *)) ;
Some (landingpad_arg instr)
| _ ->
Option.first_some retn_arg
(Option.map (unique_used_invoke_pred blk) ~f:xlate_name)
in in
(Option.cons instr_arg rev_args, pos) let lbl = find_name instr ^ ".jmp" in
| At_end blk -> fail "block_formals: %a" pp_llblock blk () let blk =
Llair.Block.mk ~lbl
(** actual arguments passed by a jump to a block *) ~cmnd:(Vector.of_array [|mov|])
let jump_args : x -> Llvm.llvalue -> Llvm.llbasicblock -> Exp.t list = ~term:(Llair.Term.goto ~dst:jmp ~loc)
fun x jmp dst -> in
let src = Llvm.instr_parent jmp in (Llair.Jump.mk lbl, blk :: blocks)
let retn_arg, rev_args, _ =
rev_map_phis dst ~f:(fun phi ->
Option.value_exn
(List.find_map (Llvm.incoming phi) ~f:(fun (arg, pred) ->
if Poly.equal pred src then Some (xlate_value x arg)
else None )) )
in
let retn_arg =
Option.first_some retn_arg
(Option.map (unique_used_invoke_pred dst) ~f:(fun invoke ->
Exp.var (xlate_name invoke) ))
in
Option.cons retn_arg rev_args
(** An LLVM instruction is translated to a sequence of LLAIR instructions (** An LLVM instruction is translated to a sequence of LLAIR instructions
and a terminator, plus some additional blocks to which it may refer and a terminator, plus some additional blocks to which it may refer
@ -1025,24 +924,21 @@ let xlate_instr :
List.rev_init num_args ~f:(fun i -> List.rev_init num_args ~f:(fun i ->
xlate_value x (Llvm.operand instr i) ) xlate_value x (Llvm.operand instr i) )
in in
let return = Llair.Jump.mk lbl [] in let areturn = xlate_name_opt instr in
Llair.Term.call ~func ~typ ~args ~loc ~return ~throw:None let return = Llair.Jump.mk lbl in
~ignore_result:false Llair.Term.call ~func ~typ ~args ~areturn ~return ~throw:None
~ignore_result:false ~loc
in in
let params = Option.to_list (xlate_name_opt instr) in
continue (fun (insts, term) -> continue (fun (insts, term) ->
let cmnd = Vector.of_list insts in let cmnd = Vector.of_list insts in
([], call, [Llair.Block.mk ~lbl ~params ~cmnd ~term]) ) ) ([], call, [Llair.Block.mk ~lbl ~cmnd ~term]) ) )
| Invoke -> ( | Invoke -> (
let reg = xlate_name_opt instr in
let llfunc = Llvm.operand instr (Llvm.num_operands instr - 3) in let llfunc = Llvm.operand instr (Llvm.num_operands instr - 3) in
let lltyp = Llvm.type_of llfunc in let lltyp = Llvm.type_of llfunc in
assert (Poly.(Llvm.classify_type lltyp = Pointer)) ; assert (Poly.(Llvm.classify_type lltyp = Pointer)) ;
let fname = Llvm.value_name llfunc in let fname = Llvm.value_name llfunc in
let return_blk = Llvm.get_normal_dest instr in let return_blk = Llvm.get_normal_dest instr in
let return_dst = label_of_block return_blk in
let unwind_blk = Llvm.get_unwind_dest instr in let unwind_blk = Llvm.get_unwind_dest instr in
let unwind_dst = label_of_block unwind_blk in
let num_args = let num_args =
if not (Llvm.is_var_arg (Llvm.element_type lltyp)) then if not (Llvm.is_var_arg (Llvm.element_type lltyp)) then
Llvm.num_arg_operands instr Llvm.num_arg_operands instr
@ -1058,15 +954,15 @@ let xlate_instr :
List.rev_init num_args ~f:(fun i -> List.rev_init num_args ~f:(fun i ->
xlate_value x (Llvm.operand instr i) ) xlate_value x (Llvm.operand instr i) )
in in
let areturn = xlate_name_opt instr in
(* intrinsics *) (* intrinsics *)
match String.split fname ~on:'.' with match String.split fname ~on:'.' with
| _ when Option.is_some (xlate_intrinsic_exp fname) -> | _ when Option.is_some (xlate_intrinsic_exp fname) ->
let arg = Option.to_list (Option.map ~f:Exp.var reg) in let dst, blocks = xlate_jump x instr return_blk loc [] in
let dst = Llair.Jump.mk return_dst arg in emit_term (Llair.Term.goto ~dst ~loc) ~blocks
emit_term (Llair.Term.goto ~dst ~loc)
| ["__llair_throw"] -> | ["__llair_throw"] ->
let dst = Llair.Jump.mk unwind_dst args in let dst, blocks = xlate_jump x instr unwind_blk loc [] in
emit_term (Llair.Term.goto ~dst ~loc) emit_term (Llair.Term.goto ~dst ~loc) ~blocks
| ["abort"] -> | ["abort"] ->
emit_term ~prefix:[Llair.Inst.abort ~loc] Llair.Term.unreachable emit_term ~prefix:[Llair.Inst.abort ~loc] Llair.Term.unreachable
| ["_Znwm" (* operator new(size_t num) *)] | ["_Znwm" (* operator new(size_t num) *)]
@ -1077,11 +973,11 @@ let xlate_instr :
let num = xlate_value x (Llvm.operand instr 0) in let num = xlate_value x (Llvm.operand instr 0) in
let llt = Llvm.type_of instr in let llt = Llvm.type_of instr in
let len = Exp.integer (Z.of_int (size_of x llt)) Typ.siz in let len = Exp.integer (Z.of_int (size_of x llt)) Typ.siz in
let args = jump_args x instr return_blk in let dst, blocks = xlate_jump x instr return_blk loc [] in
let dst = Llair.Jump.mk return_dst args in
emit_term emit_term
~prefix:[Llair.Inst.alloc ~reg ~num ~len ~loc] ~prefix:[Llair.Inst.alloc ~reg ~num ~len ~loc]
(Llair.Term.goto ~dst ~loc) (Llair.Term.goto ~dst ~loc)
~blocks
(* unimplemented *) (* unimplemented *)
| "llvm" :: "experimental" :: "gc" :: "statepoint" :: _ -> | "llvm" :: "experimental" :: "gc" :: "statepoint" :: _ ->
todo "statepoints:@ %a" pp_llvalue instr () todo "statepoints:@ %a" pp_llvalue instr ()
@ -1089,37 +985,18 @@ let xlate_instr :
| _ -> | _ ->
let func = xlate_func_name x llfunc in let func = xlate_func_name x llfunc in
let typ = xlate_type x (Llvm.type_of llfunc) in let typ = xlate_type x (Llvm.type_of llfunc) in
let return, blocks = xlate_jump x instr return_blk loc [] in
let throw, blocks = xlate_jump x instr unwind_blk loc blocks in
let throw = Some throw in
let ignore_result = let ignore_result =
match typ with match typ with
| Pointer {elt= Function {return= Some _}} -> | Pointer {elt= Function {return= Some _}} ->
not (return_formal_is_used instr) Option.is_none (Llvm.use_begin instr)
| _ -> false | _ -> false
in in
let return, blocks =
let args = trampoline_args x instr return_blk in
if not (need_return_trampoline instr return_blk) then
(Llair.Jump.mk return_dst args, [])
else
let lbl = name ^ ".ret" in
let block =
let params = [xlate_name instr] in
let cmnd = Vector.empty in
let term =
let dst = Llair.Jump.mk return_dst args in
Llair.Term.goto ~dst ~loc
in
Llair.Block.mk ~lbl ~params ~cmnd ~term
in
(Llair.Jump.mk lbl [], [block])
in
let throw =
let dst = unwind_dst in
let args = trampoline_args x instr unwind_blk in
Some (Llair.Jump.mk dst args)
in
emit_term emit_term
(Llair.Term.call ~func ~typ ~args ~loc ~return ~throw (Llair.Term.call ~func ~typ ~args ~areturn ~return ~throw
~ignore_result) ~ignore_result ~loc)
~blocks ) ~blocks )
| Ret -> | Ret ->
let exp = let exp =
@ -1130,61 +1007,53 @@ let xlate_instr :
| Br -> ( | Br -> (
match Option.value_exn (Llvm.get_branch instr) with match Option.value_exn (Llvm.get_branch instr) with
| `Unconditional blk -> | `Unconditional blk ->
let args = jump_args x instr blk in let dst, blocks = xlate_jump x instr blk loc [] in
let dst = Llair.Jump.mk (label_of_block blk) args in emit_term (Llair.Term.goto ~dst ~loc) ~blocks
emit_term (Llair.Term.goto ~dst ~loc)
| `Conditional (cnd, thn, els) -> | `Conditional (cnd, thn, els) ->
let key = xlate_value x cnd in let key = xlate_value x cnd in
let thn_lbl = label_of_block thn in let thn, blocks = xlate_jump x instr thn loc [] in
let thn_args = jump_args x instr thn in let els, blocks = xlate_jump x instr els loc blocks in
let thn = Llair.Jump.mk thn_lbl thn_args in emit_term (Llair.Term.branch ~key ~nzero:thn ~zero:els ~loc) ~blocks
let els_lbl = label_of_block els in )
let els_args = jump_args x instr els in
let els = Llair.Jump.mk els_lbl els_args in
emit_term (Llair.Term.branch ~key ~nzero:thn ~zero:els ~loc) )
| Switch -> | Switch ->
let key = xlate_value x (Llvm.operand instr 0) in let key = xlate_value x (Llvm.operand instr 0) in
let cases = let cases, blocks =
let num_cases = (Llvm.num_operands instr / 2) - 1 in let num_cases = (Llvm.num_operands instr / 2) - 1 in
let rec xlate_cases i = let rec xlate_cases i blocks =
if i <= num_cases then if i <= num_cases then
let idx = Llvm.operand instr (2 * i) in let idx = Llvm.operand instr (2 * i) in
let blk = let blk =
Llvm.block_of_value (Llvm.operand instr ((2 * i) + 1)) Llvm.block_of_value (Llvm.operand instr ((2 * i) + 1))
in in
let num = xlate_value x idx in let num = xlate_value x idx in
let dst = label_of_block blk in let jmp, blocks = xlate_jump x instr blk loc blocks in
let args = jump_args x instr blk in let rest, blocks = xlate_cases (i + 1) blocks in
let rest = xlate_cases (i + 1) in ((num, jmp) :: rest, blocks)
(num, Llair.Jump.mk dst args) :: rest else ([], blocks)
else []
in in
xlate_cases 1 xlate_cases 1 []
in in
let tbl = Vector.of_list cases in let tbl = Vector.of_list cases in
let blk = Llvm.block_of_value (Llvm.operand instr 1) in let blk = Llvm.block_of_value (Llvm.operand instr 1) in
let dst = label_of_block blk in let els, blocks = xlate_jump x instr blk loc blocks in
let args = jump_args x instr blk in emit_term (Llair.Term.switch ~key ~tbl ~els ~loc) ~blocks
let els = Llair.Jump.mk dst args in
emit_term (Llair.Term.switch ~key ~tbl ~els ~loc)
| IndirectBr -> | IndirectBr ->
let ptr = xlate_value x (Llvm.operand instr 0) in let ptr = xlate_value x (Llvm.operand instr 0) in
let num_dests = Llvm.num_operands instr - 1 in let num_dests = Llvm.num_operands instr - 1 in
let lldests = let lldests, blocks =
let rec dests i = let rec dests i blocks =
if i <= num_dests then if i <= num_dests then
let v = Llvm.operand instr i in let v = Llvm.operand instr i in
let blk = Llvm.block_of_value v in let blk = Llvm.block_of_value v in
let dst = label_of_block blk in let jmp, blocks = xlate_jump x instr blk loc blocks in
let args = jump_args x instr blk in let rest, blocks = dests (i + 1) blocks in
let rest = dests (i + 1) in (jmp :: rest, blocks)
Llair.Jump.mk dst args :: rest else ([], blocks)
else []
in in
dests 1 dests 1 []
in in
let tbl = Vector.of_list lldests in let tbl = Vector.of_list lldests in
emit_term (Llair.Term.iswitch ~ptr ~tbl ~loc) emit_term (Llair.Term.iswitch ~ptr ~tbl ~loc) ~blocks
| LandingPad -> | LandingPad ->
(* Translate the landingpad clauses to code to load the type_info from (* Translate the landingpad clauses to code to load the type_info from
the thrown exception, and test the type_info against the clauses, the thrown exception, and test the type_info against the clauses,
@ -1192,7 +1061,7 @@ 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 (landingpad_arg instr) in let exc = Exp.var (Var.program (find_name instr ^ ".exc")) in
let ti = Var.program (name ^ ".ti") in let ti = Var.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 =
@ -1213,33 +1082,44 @@ let xlate_instr :
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
let params = [param] in let jump_unwind i sel rev_blocks =
let jump_unwind sel = let arg = Exp.record [exc; sel] in
let dst = lbl in let mov =
let args = [Exp.record [exc; sel]] in Llair.Inst.move ~reg_exps:(Vector.of_array [|(param, arg)|]) ~loc
Llair.Jump.mk dst args in
let lbl = lbl ^ "." ^ Int.to_string i in
let blk =
Llair.Block.mk ~lbl
~cmnd:(Vector.of_array [|mov|])
~term:(Llair.Term.goto ~dst:(Llair.Jump.mk lbl) ~loc)
in
(Llair.Jump.mk lbl, blk :: rev_blocks)
in in
let goto_unwind sel = let goto_unwind i sel blocks =
let dst = jump_unwind sel in let dst, blocks = jump_unwind i sel blocks in
Llair.Term.goto ~dst ~loc (Llair.Term.goto ~dst ~loc, blocks)
in in
let term_unwind, rev_blocks = let term_unwind, rev_blocks =
if Llvm.is_cleanup instr then if Llvm.is_cleanup instr then
(goto_unwind (Exp.integer Z.zero i32), []) goto_unwind 0 (Exp.integer Z.zero i32) []
else else
let num_clauses = Llvm.num_operands instr in let num_clauses = Llvm.num_operands instr in
let lbl i = name ^ "." ^ Int.to_string i in let lbl i = name ^ "." ^ Int.to_string i in
let jump i = Llair.Jump.mk (lbl i) [] in let jump i = Llair.Jump.mk (lbl i) in
let block i term = let block i term =
Llair.Block.mk ~lbl:(lbl i) ~params:[] ~cmnd:Vector.empty ~term Llair.Block.mk ~lbl:(lbl i) ~cmnd:Vector.empty ~term
in in
let match_filter = let match_filter i rev_blocks =
jump_unwind (Exp.sub i32 (Exp.integer Z.zero i32) typeid) jump_unwind i
(Exp.sub i32 (Exp.integer Z.zero i32) typeid)
rev_blocks
in in
let xlate_clause i = let xlate_clause i rev_blocks =
let clause = Llvm.operand instr i in let clause = Llvm.operand instr i in
let num_tis = Llvm.num_operands clause in let num_tis = Llvm.num_operands clause in
if num_tis = 0 then Llair.Term.goto ~dst:match_filter ~loc if num_tis = 0 then
let dst, rev_blocks = match_filter i rev_blocks in
(Llair.Term.goto ~dst ~loc, rev_blocks)
else else
match Llvm.classify_type (Llvm.type_of clause) with match Llvm.classify_type (Llvm.type_of clause) with
| Array (* filter *) -> ( | Array (* filter *) -> (
@ -1252,30 +1132,32 @@ let xlate_instr :
else Exp.dq tiI ti else Exp.dq tiI ti
in in
let key = xlate_filter 0 in let key = xlate_filter 0 in
Llair.Term.branch ~loc ~key ~nzero:match_filter let nzero, rev_blocks = match_filter i rev_blocks in
~zero:(jump (i + 1)) ( Llair.Term.branch ~loc ~key ~nzero ~zero:(jump (i + 1))
, rev_blocks )
| _ -> fail "xlate_instr: %a" pp_llvalue instr () ) | _ -> fail "xlate_instr: %a" pp_llvalue instr () )
| _ (* catch *) -> | _ (* catch *) ->
let clause = xlate_value x clause in let clause = xlate_value x clause in
let key = let key =
Exp.or_ (Exp.eq clause Exp.null) (Exp.eq clause ti) Exp.or_ (Exp.eq clause Exp.null) (Exp.eq clause ti)
in in
Llair.Term.branch ~loc ~key ~nzero:(jump_unwind typeid) let nzero, rev_blocks = jump_unwind i typeid rev_blocks in
~zero:(jump (i + 1)) ( Llair.Term.branch ~loc ~key ~nzero ~zero:(jump (i + 1))
, rev_blocks )
in in
let rec rev_blocks i z = let rec rev_blocks i z =
if i < num_clauses then if i < num_clauses then
rev_blocks (i + 1) (block i (xlate_clause i) :: z) let term, z = xlate_clause i z in
rev_blocks (i + 1) (block i term :: z)
else block i Llair.Term.unreachable :: z else block i Llair.Term.unreachable :: z
in in
(xlate_clause 0, rev_blocks 1 []) xlate_clause 0 (rev_blocks 1 [])
in in
continue (fun (insts, term) -> continue (fun (insts, term) ->
( [load_ti] ( [load_ti]
, term_unwind , term_unwind
, List.rev_append rev_blocks , List.rev_append rev_blocks
[ Llair.Block.mk ~lbl ~params ~cmnd:(Vector.of_list insts) [Llair.Block.mk ~lbl ~cmnd:(Vector.of_list insts) ~term] ) )
~term ] ) )
| Resume -> | Resume ->
let rcd = xlate_value x (Llvm.operand instr 0) in let rcd = xlate_value x (Llvm.operand instr 0) in
let exc = Exp.select ~rcd ~idx:(Exp.integer Z.zero Typ.siz) in let exc = Exp.select ~rcd ~idx:(Exp.integer Z.zero Typ.siz) in
@ -1298,6 +1180,18 @@ let xlate_instr :
fail "xlate_instr: %a" pp_llvalue instr () fail "xlate_instr: %a" pp_llvalue instr ()
| PHI | Invalid | Invalid2 | UserOp1 | UserOp2 -> assert false | PHI | Invalid | Invalid2 | UserOp1 | UserOp2 -> assert false
let skip_phis : Llvm.llbasicblock -> _ Llvm.llpos =
fun blk ->
let rec skip_phis_ (pos : _ Llvm.llpos) =
match pos with
| Before instr -> (
match Llvm.instr_opcode instr with
| PHI -> skip_phis_ (Llvm.instr_succ instr)
| _ -> pos )
| _ -> pos
in
skip_phis_ (Llvm.instr_begin blk)
let rec xlate_instrs : pop_thunk -> x -> _ Llvm.llpos -> code = let rec xlate_instrs : pop_thunk -> x -> _ Llvm.llpos -> code =
fun pop x -> function fun pop x -> function
| Before instrI -> | Before instrI ->
@ -1313,9 +1207,9 @@ let xlate_block : pop_thunk -> x -> Llvm.llbasicblock -> Llair.block list =
[%Trace.call fun {pf} -> pf "%a" pp_llblock blk] [%Trace.call fun {pf} -> pf "%a" pp_llblock blk]
; ;
let lbl = label_of_block blk in let lbl = label_of_block blk in
let params, pos = block_formals blk in let pos = skip_phis blk in
let insts, term, blocks = xlate_instrs pop x pos in let insts, term, blocks = xlate_instrs pop x pos in
Llair.Block.mk ~lbl ~params ~cmnd:(Vector.of_list insts) ~term :: blocks Llair.Block.mk ~lbl ~cmnd:(Vector.of_list insts) ~term :: blocks
|> |>
[%Trace.retn fun {pf} blocks -> pf "%s" (List.hd_exn blocks).Llair.lbl] [%Trace.retn fun {pf} blocks -> pf "%s" (List.hd_exn blocks).Llair.lbl]
@ -1341,8 +1235,7 @@ let xlate_function : x -> Llvm.llvalue -> Llair.func =
in in
let entry = let entry =
let {Llair.lbl; cmnd; term} = entry_block in let {Llair.lbl; cmnd; term} = entry_block in
assert (List.is_empty entry_block.params) ; Llair.Block.mk ~lbl ~cmnd ~term
Llair.Block.mk ~lbl ~params ~cmnd ~term
in in
let cfg = let cfg =
let rec trav_blocks rev_cfg prev = let rec trav_blocks rev_cfg prev =
@ -1355,7 +1248,7 @@ let xlate_function : x -> Llvm.llvalue -> Llair.func =
in in
trav_blocks (List.rev entry_blocks) entry_blk trav_blocks (List.rev entry_blocks) entry_blk
in in
Llair.Func.mk ~name ~entry ~cfg Llair.Func.mk ~name ~params ~entry ~cfg
| At_end _ -> | At_end _ ->
report_undefined llf name ; report_undefined llf name ;
Llair.Func.mk_undefined ~name ~params ) Llair.Func.mk_undefined ~name ~params )

296
sledge/src/llair/llair.ml
Unescape View File

@ -5,7 +5,9 @@
* LICENSE file in the root directory of this source tree. * LICENSE file in the root directory of this source tree.
*) *)
(** Translation units *) (** LLAIR (Low-Level Analysis Internal Representation) *)
[@@@warning "+9"]
type inst = type inst =
| Move of {reg_exps: (Var.t * Exp.t) vector; loc: Loc.t} | Move of {reg_exps: (Var.t * Exp.t) vector; loc: Loc.t}
@ -23,29 +25,29 @@ type inst =
type cmnd = inst vector [@@deriving sexp] type cmnd = inst vector [@@deriving sexp]
type label = string [@@deriving sexp] type label = string [@@deriving sexp]
type 'a control_transfer = type jump = {mutable dst: block; mutable retreating: bool}
{mutable dst: 'a; args: Exp.t list; mutable retreating: bool}
[@@deriving compare, equal, sexp_of]
type jump = block control_transfer and 'a call =
{ callee: 'a
; typ: Typ.t
; args: Exp.t list
; areturn: Var.t option
; return: jump
; throw: jump option
; ignore_result: bool
; mutable recursive: bool
; loc: Loc.t }
and term = and term =
| Switch of {key: Exp.t; tbl: (Exp.t * jump) vector; els: jump; loc: Loc.t} | Switch of {key: Exp.t; tbl: (Exp.t * jump) vector; els: jump; loc: Loc.t}
| Iswitch of {ptr: Exp.t; tbl: jump vector; loc: Loc.t} | Iswitch of {ptr: Exp.t; tbl: jump vector; loc: Loc.t}
| Call of | Call of Exp.t call
{ call: Exp.t control_transfer
; typ: Typ.t
; return: jump
; throw: jump option
; ignore_result: bool
; loc: Loc.t }
| Return of {exp: Exp.t option; loc: Loc.t} | Return of {exp: Exp.t option; loc: Loc.t}
| Throw of {exc: Exp.t; loc: Loc.t} | Throw of {exc: Exp.t; loc: Loc.t}
| Unreachable | Unreachable
and block = and block =
{ lbl: label { lbl: label
; params: Var.t list
; cmnd: cmnd ; cmnd: cmnd
; term: term ; term: term
; mutable parent: func ; mutable parent: func
@ -53,15 +55,15 @@ and block =
and cfg = block vector and cfg = block vector
(* [entry] is not part of [cfg] since it is special in several ways: its (* [entry] is not part of [cfg] since it cannot be jumped to, only called. *)
params are the func params, and it cannot be jumped to, only called. *)
and func = and func =
{ name: Global.t { name: Global.t
; params: Var.t list
; freturn: Var.t option
; fthrow: Var.t
; locals: Var.Set.t ; locals: Var.Set.t
; entry: block ; entry: block
; cfg: cfg ; cfg: cfg }
; freturn: Var.t option
; fthrow: Var.t }
let sexp_cons (hd : Sexp.t) (tl : Sexp.t) = let sexp_cons (hd : Sexp.t) (tl : Sexp.t) =
match tl with match tl with
@ -70,8 +72,8 @@ let sexp_cons (hd : Sexp.t) (tl : Sexp.t) =
let sexp_ctor label args = sexp_cons (Sexp.Atom label) args let sexp_ctor label args = sexp_cons (Sexp.Atom label) args
let sexp_of_jump {dst; args; retreating} = let sexp_of_jump {dst; retreating} =
[%sexp {dst: label = dst.lbl; args: Exp.t list; retreating: bool}] [%sexp {dst: label = dst.lbl; retreating: bool}]
let sexp_of_term = function let sexp_of_term = function
| Switch {key; tbl; els; loc} -> | Switch {key; tbl; els; loc} ->
@ -80,24 +82,35 @@ let sexp_of_term = function
{key: Exp.t; tbl: (Exp.t * jump) vector; els: jump; loc: Loc.t}] {key: Exp.t; tbl: (Exp.t * jump) vector; els: jump; loc: Loc.t}]
| Iswitch {ptr; tbl; loc} -> | Iswitch {ptr; tbl; loc} ->
sexp_ctor "Iswitch" [%sexp {ptr: Exp.t; tbl: jump vector; loc: Loc.t}] sexp_ctor "Iswitch" [%sexp {ptr: Exp.t; tbl: jump vector; loc: Loc.t}]
| Call {call; typ; return; throw; ignore_result; loc} -> | Call
{ callee
; typ
; args
; areturn
; return
; throw
; ignore_result
; recursive
; loc } ->
sexp_ctor "Call" sexp_ctor "Call"
[%sexp [%sexp
{ call: Exp.t control_transfer { callee: Exp.t
; typ: Typ.t ; typ: Typ.t
; args: Exp.t list
; areturn: Var.t option
; return: jump ; return: jump
; throw: jump option ; throw: jump option
; ignore_result: bool ; ignore_result: bool
; recursive: bool
; loc: Loc.t }] ; loc: Loc.t }]
| Return {exp; loc} -> | Return {exp; loc} ->
sexp_ctor "Return" [%sexp {exp: Exp.t option; loc: Loc.t}] sexp_ctor "Return" [%sexp {exp: Exp.t option; loc: Loc.t}]
| Throw {exc; loc} -> sexp_ctor "Throw" [%sexp {exc: Exp.t; loc: Loc.t}] | Throw {exc; loc} -> sexp_ctor "Throw" [%sexp {exc: Exp.t; loc: Loc.t}]
| Unreachable -> Sexp.Atom "Unreachable" | Unreachable -> Sexp.Atom "Unreachable"
let sexp_of_block {lbl; params; cmnd; term; parent; sort_index} = let sexp_of_block {lbl; cmnd; term; parent; sort_index} =
[%sexp [%sexp
{ lbl: label { lbl: label
; params: Var.t list
; cmnd: cmnd ; cmnd: cmnd
; term: term ; term: term
; parent: Var.t = parent.name.var ; parent: Var.t = parent.name.var
@ -105,8 +118,15 @@ let sexp_of_block {lbl; params; cmnd; term; parent; sort_index} =
let sexp_of_cfg v = [%sexp_of: block vector] v let sexp_of_cfg v = [%sexp_of: block vector] v
let sexp_of_func {name; locals; entry; cfg} = let sexp_of_func {name; params; freturn; fthrow; locals; entry; cfg} =
[%sexp {name: Global.t; locals: Var.Set.t; entry: block; cfg: cfg}] [%sexp
{ name: Global.t
; params: Var.t list
; freturn: Var.t option
; fthrow: Var.t
; locals: Var.Set.t
; entry: block
; cfg: cfg }]
(* blocks in a [t] are uniquely identified by [sort_index] *) (* blocks in a [t] are uniquely identified by [sort_index] *)
let compare_block x y = Int.compare x.sort_index y.sort_index let compare_block x y = Int.compare x.sort_index y.sort_index
@ -125,7 +145,7 @@ let pp_inst fs inst =
pf "@[<2>@[%a@]@ := @[%a@];@]\t%a" (Vector.pp ",@ " Var.pp) regs pf "@[<2>@[%a@]@ := @[%a@];@]\t%a" (Vector.pp ",@ " Var.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>load %a@ %a@ %a;@]\t%a" Exp.pp len Var.pp reg Exp.pp ptr pf "@[<2>%a@ := load %a@ %a;@]\t%a" Var.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
@ -140,12 +160,13 @@ 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>alloc %a@ [%a x %a];@]\t%a" Var.pp reg Exp.pp num Exp.pp len pf "@[<2>%a@ := alloc [%a x %a];@]\t%a" Var.pp reg Exp.pp num Exp.pp
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>nondet %a\"%s\";@]\t%a" (Option.pp "%a " Var.pp) reg msg pf "@[<2>%anondet \"%s\";@]\t%a"
Loc.pp loc (Option.pp "%a := " Var.pp)
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 =
@ -153,10 +174,10 @@ let pp_args pp_arg fs args =
let pp_param fs var = Var.pp fs var let pp_param fs var = Var.pp fs var
let pp_jump fs {dst= {lbl}; args; retreating} = let pp_jump fs {dst; retreating} =
Format.fprintf fs "@[<2>%s%%%s%a@]" Format.fprintf fs "@[<2>%s%%%s@]"
(if retreating then "↑" else "") (if retreating then "↑" else "")
lbl (pp_args Exp.pp) args dst.lbl
let pp_term fs term = let pp_term fs term =
let pf pp = Format.fprintf fs pp in let pf pp = Format.fprintf fs pp in
@ -175,13 +196,15 @@ let pp_term fs term =
tbl pp_goto els Loc.pp loc ) tbl pp_goto els Loc.pp loc )
| Iswitch {ptr; tbl; loc} -> | Iswitch {ptr; tbl; loc} ->
pf "@[<2>iswitch %a@ @[<hv>%a@]@]\t%a" Exp.pp ptr pf "@[<2>iswitch %a@ @[<hv>%a@]@]\t%a" Exp.pp ptr
(Vector.pp "@ " (fun fs ({dst= {lbl}; _} as jmp) -> (Vector.pp "@ " (fun fs jmp ->
Format.fprintf fs "%s: %a" lbl pp_goto jmp )) Format.fprintf fs "%s: %a" jmp.dst.lbl pp_goto jmp ))
tbl Loc.pp loc tbl Loc.pp loc
| Call {call= {dst; args; retreating}; return; throw; loc} -> | Call {callee; args; areturn; return; throw; recursive; loc; _} ->
pf "@[<2>@[<7>call @[<2>%s%a%a@]@]@ @[returnto %a%a;@]@]\t%a" pf "@[<2>@[<7>%acall @[<2>%s%a%a@]@]@ @[returnto %a%a;@]@]\t%a"
(if retreating then "↑" else "") (Option.pp "%a := " Var.pp)
Exp.pp dst (pp_args Exp.pp) args pp_jump return areturn
(if recursive then "↑" else "")
Exp.pp callee (pp_args Exp.pp) args pp_jump return
(Option.pp "@ throwto %a" pp_jump) (Option.pp "@ throwto %a" pp_jump)
throw Loc.pp loc throw Loc.pp loc
| Return {exp; loc} -> | Return {exp; loc} ->
@ -191,9 +214,9 @@ let pp_term fs term =
let pp_cmnd = Vector.pp "@ " pp_inst let pp_cmnd = Vector.pp "@ " pp_inst
let pp_block fs {lbl; params; cmnd; term; sort_index} = let pp_block fs {lbl; cmnd; term; parent= _; sort_index} =
Format.fprintf fs "@[<v 2>@[<4>%s%a@]: #%i@ @[<v>%a%t%a@]@]" lbl Format.fprintf fs "@[<v 2>%s: #%i@ @[<v>%a%t%a@]@]" lbl sort_index pp_cmnd
(pp_args pp_param) params sort_index pp_cmnd cmnd cmnd
(fun fs -> if Vector.is_empty cmnd then () else Format.fprintf fs "@ ") (fun fs -> if Vector.is_empty cmnd then () else Format.fprintf fs "@ ")
pp_term term pp_term term
@ -201,7 +224,6 @@ let pp_block fs {lbl; params; cmnd; term; sort_index} =
let rec dummy_block = let rec dummy_block =
{ lbl= "dummy" { lbl= "dummy"
; params= []
; cmnd= Vector.empty ; cmnd= Vector.empty
; term= Unreachable ; term= Unreachable
; parent= dummy_func ; parent= dummy_func
@ -211,11 +233,12 @@ and dummy_func =
let dummy_var = Var.program "dummy" in let dummy_var = Var.program "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_var dummy_ptr_typ Loc.none
; params= []
; freturn= None
; fthrow= dummy_var
; locals= Var.Set.empty ; locals= Var.Set.empty
; entry= dummy_block ; entry= dummy_block
; cfg= Vector.empty ; cfg= Vector.empty }
; freturn= None
; fthrow= dummy_var }
(** Instructions *) (** Instructions *)
@ -235,25 +258,26 @@ module Inst = struct
let abort ~loc = Abort {loc} let abort ~loc = Abort {loc}
let loc = function let loc = function
| Move {loc} | Move {loc; _}
|Load {loc} |Load {loc; _}
|Store {loc} |Store {loc; _}
|Memset {loc} |Memset {loc; _}
|Memcpy {loc} |Memcpy {loc; _}
|Memmov {loc} |Memmov {loc; _}
|Alloc {loc} |Alloc {loc; _}
|Free {loc} |Free {loc; _}
|Nondet {loc} |Nondet {loc; _}
|Abort {loc} -> |Abort {loc; _} ->
loc loc
let union_locals inst vs = let union_locals inst vs =
match inst with match inst with
| Move {reg_exps} -> | Move {reg_exps; _} ->
Vector.fold ~f:(fun vs (reg, _) -> Set.add vs reg) ~init:vs reg_exps Vector.fold ~f:(fun vs (reg, _) -> Set.add vs reg) ~init:vs reg_exps
| Load {reg} | Alloc {reg} | Nondet {reg= Some reg} -> Set.add vs reg | Load {reg; _} | Alloc {reg; _} | Nondet {reg= Some reg; _} ->
Set.add vs reg
| Store _ | Memcpy _ | Memmov _ | Memset _ | Free _ | Store _ | Memcpy _ | Memmov _ | Memset _ | Free _
|Nondet {reg= None} |Nondet {reg= None; _}
|Abort _ -> |Abort _ ->
vs vs
@ -265,26 +289,10 @@ end
module Jump = struct module Jump = struct
type t = jump [@@deriving sexp_of] type t = jump [@@deriving sexp_of]
let compare = compare_control_transfer compare_block let compare x y = compare_block x.dst y.dst
let equal = equal_control_transfer equal_block let equal x y = equal_block x.dst y.dst
let pp = pp_jump let pp = pp_jump
let mk lbl = {dst= {dummy_block with lbl}; retreating= false}
let invariant ?(accept_return = false) jmp =
Invariant.invariant [%here] (jmp, accept_return) [%sexp_of: t * bool]
@@ fun () ->
let {dst= {params; parent}; args} = jmp in
if parent == dummy_func then
(* jmp not yet backpatched by Func.mk *)
assert true
else
assert (
List.length params = List.length args + Bool.to_int accept_return )
let mk lbl args =
{dst= {dummy_block with lbl}; args; retreating= false}
|> check invariant
let push_arg arg jmp = {jmp with args= arg :: jmp.args}
end end
(** Basic-Block Terminators *) (** Basic-Block Terminators *)
@ -298,19 +306,14 @@ module Term = struct
Invariant.invariant [%here] term [%sexp_of: t] Invariant.invariant [%here] term [%sexp_of: t]
@@ fun () -> @@ fun () ->
match term with match term with
| Switch {tbl; els} -> | Switch _ | Iswitch _ -> assert true
Vector.iter tbl ~f:(fun (_, jmp) -> Jump.invariant jmp) ; | Call {typ; args= actls; areturn; _} -> (
Jump.invariant els
| Iswitch {tbl} -> Vector.iter tbl ~f:Jump.invariant
| Call {call= {args= actls}; typ; return; throw; ignore_result} -> (
match typ with match typ with
| Pointer {elt= Function {args= frmls; return= retn_typ}} -> | Pointer {elt= Function {args= frmls; return= retn_typ; _}} ->
assert (Vector.length frmls = List.length actls) ; assert (Vector.length frmls = List.length actls) ;
Jump.invariant return assert (Option.is_some retn_typ || Option.is_none areturn)
~accept_return:(Option.is_some retn_typ && not ignore_result) ;
Option.iter throw ~f:(Jump.invariant ~accept_return:true)
| _ -> assert false ) | _ -> assert false )
| Return {exp} -> ( | Return {exp; _} -> (
match parent with match parent with
| Some parent -> | Some parent ->
assert (Bool.(Option.is_some exp = Option.is_some parent.freturn)) assert (Bool.(Option.is_some exp = Option.is_some parent.freturn))
@ -331,19 +334,36 @@ module Term = struct
let iswitch ~ptr ~tbl ~loc = Iswitch {ptr; tbl; loc} |> check invariant let iswitch ~ptr ~tbl ~loc = Iswitch {ptr; tbl; loc} |> check invariant
let call ~func ~typ ~args ~return ~throw ~ignore_result ~loc = let call ~func ~typ ~args ~areturn ~return ~throw ~ignore_result ~loc =
let call = {dst= func; args; retreating= false} in Call
Call {call; typ; return; throw; ignore_result; loc} |> check invariant { callee= func
; typ
; args
; areturn
; return
; throw
; ignore_result
; recursive= false
; loc }
|> check invariant
let return ~exp ~loc = Return {exp; loc} |> check invariant let return ~exp ~loc = Return {exp; loc} |> check invariant
let throw ~exc ~loc = Throw {exc; loc} |> check invariant let throw ~exc ~loc = Throw {exc; loc} |> check invariant
let unreachable = Unreachable |> check invariant let unreachable = Unreachable |> check invariant
let loc = function let loc = function
| Switch {loc} | Iswitch {loc} | Call {loc} | Return {loc} | Throw {loc} | Switch {loc; _}
-> |Iswitch {loc; _}
|Call {loc; _}
|Return {loc; _}
|Throw {loc; _} ->
loc loc
| Unreachable -> Loc.none | Unreachable -> Loc.none
let union_locals term vs =
match term with
| Call {areturn; _} -> Set.add_option areturn vs
| _ -> vs
end end
(** Basic-Blocks *) (** Basic-Blocks *)
@ -355,19 +375,12 @@ module Block = struct
let pp = pp_block let pp = pp_block
let invariant blk = let mk ~lbl ~cmnd ~term =
Invariant.invariant [%here] blk [%sexp_of: t]
@@ fun () ->
assert (not (List.contains_dup blk.params ~compare:Var.compare))
let mk ~lbl ~params ~cmnd ~term =
{ lbl { lbl
; params
; cmnd ; cmnd
; term ; term
; parent= dummy_block.parent ; parent= dummy_block.parent
; sort_index= dummy_block.sort_index } ; sort_index= dummy_block.sort_index }
|> check invariant
end end
(** Functions *) (** Functions *)
@ -376,16 +389,25 @@ module Func = struct
type t = func [@@deriving sexp_of] type t = func [@@deriving sexp_of]
let is_undefined = function let is_undefined = function
| {entry= {cmnd; term= Unreachable}} -> Vector.is_empty cmnd | {entry= {cmnd; term= Unreachable; _}; _} -> Vector.is_empty cmnd
| _ -> false | _ -> false
let pp fs ({name; entry= {params; cmnd; term; sort_index}; cfg} as func) = let pp fs
( { name
; params
; freturn
; fthrow= _
; locals= _
; entry= {cmnd; term; sort_index; _}
; cfg } as func ) =
let pp_if cnd str fs = if cnd then Format.fprintf fs str in let pp_if cnd str fs = if cnd then Format.fprintf fs str in
Format.fprintf fs "@[<v>@[<v>%a@[<2>%a%a@]%t@]" (Option.pp "%a " Typ.pp) Format.fprintf fs "@[<v>@[<v>%a%a@[<2>%a%a@]%t@]"
(Option.pp "%a " Typ.pp)
( match name.typ with ( match name.typ with
| Pointer {elt= Function {return}} -> return | Pointer {elt= Function {return; _}} -> return
| _ -> None ) | _ -> None )
Global.pp name (pp_args pp_param) params (Option.pp " %a := " Var.pp)
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
else else
@ -395,57 +417,51 @@ module Func = struct
(Vector.pp "@\n@\n " Block.pp) (Vector.pp "@\n@\n " Block.pp)
cfg ) cfg )
let fold_term {entry= {term}; cfg} ~init ~f = let fold_term {entry; cfg; _} ~init ~f =
Vector.fold cfg ~init:(f init term) ~f:(fun a {term} -> f a term) Vector.fold cfg ~init:(f init entry.term) ~f:(fun a blk -> f a blk.term)
let iter_term {entry= {term}; cfg} ~f = let iter_term {entry; cfg; _} ~f =
f term ; f entry.term ;
Vector.iter cfg ~f:(fun {term} -> f term) Vector.iter cfg ~f:(fun blk -> f blk.term)
let invariant func = let invariant func =
Invariant.invariant [%here] func [%sexp_of: t] Invariant.invariant [%here] func [%sexp_of: t]
@@ fun () -> @@ fun () ->
assert (func == func.entry.parent) ; assert (func == func.entry.parent) ;
let {name= {typ}; entry; cfg} = func in let {name= {typ; _}; cfg; _} = func in
match typ with match typ with
| Pointer {elt= Function {return}} -> | Pointer {elt= Function {return; _}} ->
assert ( assert (
not not
(Vector.contains_dup cfg ~compare:(fun b1 b2 -> (Vector.contains_dup cfg ~compare:(fun b1 b2 ->
String.compare b1.lbl b2.lbl )) ) ; String.compare b1.lbl b2.lbl )) ) ;
assert (
not
(List.contains_dup
(List.concat_map (entry :: Vector.to_list cfg) ~f:(fun blk ->
blk.params ))
~compare:Var.compare) ) ;
assert (Bool.(Option.is_some return = Option.is_some func.freturn)) ; assert (Bool.(Option.is_some return = Option.is_some func.freturn)) ;
iter_term func ~f:(fun term -> Term.invariant ~parent:func term) iter_term func ~f:(fun term -> Term.invariant ~parent:func term)
| _ -> assert false | _ -> assert false
let find functions name = Map.find functions name let find functions name = Map.find functions name
let mk ~(name : Global.t) ~entry ~cfg = let mk ~(name : Global.t) ~params ~entry ~cfg =
let locals = let locals =
let locals_cmnd locals cmnd = let locals_cmnd locals cmnd =
Vector.fold_right ~f:Inst.union_locals cmnd ~init:locals Vector.fold_right ~f:Inst.union_locals cmnd ~init:locals
in in
let locals_block locals block = let locals_block locals block =
Set.add_list block.params (locals_cmnd locals block.cmnd) locals_cmnd (Term.union_locals block.term locals) block.cmnd
in in
let init = locals_cmnd Var.Set.empty entry.cmnd in let init = locals_block Var.Set.empty entry in
Vector.fold ~f:locals_block cfg ~init Vector.fold ~f:locals_block cfg ~init
in in
let wrt = Set.add_list entry.params locals in let wrt = Set.add_list params locals in
let freturn, wrt = let freturn, wrt =
match name.typ with match name.typ with
| Pointer {elt= Function {return= Some _}} -> | Pointer {elt= Function {return= Some _; _}} ->
let freturn, wrt = Var.fresh "freturn" ~wrt in let freturn, wrt = Var.fresh "freturn" ~wrt in
(Some freturn, wrt) (Some freturn, wrt)
| _ -> (None, wrt) | _ -> (None, wrt)
in in
let fthrow, _ = Var.fresh "fthrow" ~wrt in let fthrow, _ = Var.fresh "fthrow" ~wrt in
let func = {name; locals; entry; cfg; freturn; fthrow} in let func = {name; params; freturn; fthrow; locals; entry; cfg} in
let resolve_parent_and_jumps block = let resolve_parent_and_jumps block =
block.parent <- func ; block.parent <- func ;
let lookup cfg lbl : block = let lookup cfg lbl : block =
@ -453,11 +469,11 @@ module Func = struct
in in
let set_dst jmp = jmp.dst <- lookup cfg jmp.dst.lbl in let set_dst jmp = jmp.dst <- lookup cfg jmp.dst.lbl in
match block.term with match block.term with
| Switch {tbl; els} -> | Switch {tbl; els; _} ->
Vector.iter tbl ~f:(fun (_, jmp) -> set_dst jmp) ; Vector.iter tbl ~f:(fun (_, jmp) -> set_dst jmp) ;
set_dst els set_dst els
| Iswitch {tbl} -> Vector.iter tbl ~f:set_dst | Iswitch {tbl; _} -> Vector.iter tbl ~f:set_dst
| Call {return; throw} -> | Call {return; throw; _} ->
set_dst return ; set_dst return ;
Option.iter throw ~f:set_dst Option.iter throw ~f:set_dst
| Return _ | Throw _ | Unreachable -> () | Return _ | Throw _ | Unreachable -> ()
@ -468,10 +484,10 @@ module Func = struct
let mk_undefined ~name ~params = let mk_undefined ~name ~params =
let entry = let entry =
Block.mk ~lbl:"" ~params ~cmnd:Vector.empty ~term:Term.unreachable Block.mk ~lbl:"" ~cmnd:Vector.empty ~term:Term.unreachable
in in
let cfg = Vector.empty in let cfg = Vector.empty in
mk ~name ~entry ~cfg mk ~name ~entry ~params ~cfg
end end
(** Derived meta-data *) (** Derived meta-data *)
@ -509,8 +525,8 @@ let set_derived_metadata functions =
FuncQ.enqueue_back_exn roots func.name.var func ) ; FuncQ.enqueue_back_exn roots func.name.var 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 {call= {dst}} -> ( | Call {callee; _} -> (
match Var.of_exp dst with match Var.of_exp callee with
| Some callee -> | Some callee ->
FuncQ.remove roots callee |> (ignore : [> ] -> unit) FuncQ.remove roots callee |> (ignore : [> ] -> unit)
| None -> () ) | None -> () )
@ -528,18 +544,18 @@ let set_derived_metadata functions =
else visit ancestors func jmp.dst else visit ancestors func jmp.dst
in in
( match src.term with ( match src.term with
| Switch {tbl; els} -> | Switch {tbl; els; _} ->
Vector.iter tbl ~f:(fun (_, jmp) -> jump jmp) ; Vector.iter tbl ~f:(fun (_, jmp) -> jump jmp) ;
jump els jump els
| Iswitch {tbl} -> Vector.iter tbl ~f:jump | Iswitch {tbl; _} -> Vector.iter tbl ~f:jump
| Call {call= {dst} as call; return; throw} -> | Call ({callee; return; throw; _} as call) ->
( match Var.of_exp dst >>= Func.find functions with ( match Var.of_exp callee >>= Func.find functions with
| Some func -> | Some func ->
if Set.mem ancestors func.entry then call.retreating <- true if Set.mem ancestors func.entry then call.recursive <- true
else visit ancestors func func.entry else visit ancestors func func.entry
| None -> | None ->
(* conservatively assume all virtual calls are recursive *) (* conservatively assume all virtual calls are recursive *)
call.retreating <- true ) ; call.recursive <- true ) ;
jump return ; Option.iter ~f:jump throw jump return ; Option.iter ~f:jump throw
| Return _ | Throw _ | Unreachable -> () ) ; | Return _ | Throw _ | Unreachable -> () ) ;
BlockQ.enqueue_back_exn tips_to_roots src () BlockQ.enqueue_back_exn tips_to_roots src ()
@ -555,7 +571,7 @@ let set_derived_metadata functions =
index := !index - 1 ) index := !index - 1 )
in in
let sort_cfgs functions = let sort_cfgs functions =
Map.iter functions ~f:(fun {cfg} -> Map.iter functions ~f:(fun {cfg; _} ->
Array.sort Array.sort
~compare:(fun x y -> Int.compare x.sort_index y.sort_index) ~compare:(fun x y -> Int.compare x.sort_index y.sort_index)
(Vector.to_array cfg) ) (Vector.to_array cfg) )

83
sledge/src/llair/llair.mli
Unescape View File

@ -5,28 +5,8 @@
* LICENSE file in the root directory of this source tree. * LICENSE file in the root directory of this source tree.
*) *)
(** Translation units (** LLAIR (Low-Level Analysis Internal Representation) is an IR tailored for
static analysis using a low-level model of memory. *)
LLAIR (Low-Level Analysis Internal Representation) is an IR tailored for
static analysis using a low-level model of memory. Compared to a
compiler IR such as LLVM, an analyzer does not need to perform register
allocation, instruction selection, code generation, etc. or even much
code transformation, so the constraints on the IR are very different.
LLAIR is a "Functional SSA" form where control transfers pass arguments
instead of using ϕ-nodes. An analyzer will need good support for
parameter passing anyhow, and ϕ-nodes make it hard to express program
properties as predicates on states, since some execution history is
needed to evaluate ϕ instructions. An alternative view is that the scope
of variables [reg] assigned in instructions such as [Load] is the
successor block as well as all blocks the instruction dominates in the
control-flow graph. This language is first-order, and a term structure
for the code constituting the scope of variables is not needed, so SSA
rather than full CPS suffices.
Additionally, the focus on memory analysis leads to a design where the
arithmetic and logic operations are not "instructions" but instead are
complex expressions (see [Exp]) that refer to registers (see [Var]). *)
(** Instructions for memory manipulation or other non-control effects. *) (** Instructions for memory manipulation or other non-control effects. *)
type inst = private type inst = private
@ -61,15 +41,21 @@ type cmnd = inst vector
(** A label is a name of a block. *) (** A label is a name of a block. *)
type label = string type label = string
(** A jump with arguments. *) (** A jump to a block. *)
type 'a control_transfer = type jump = {mutable dst: block; mutable retreating: bool}
{ mutable dst: 'a
; args: Exp.t list (** Stack of arguments, first-arg-last *) (** A call to a function. *)
; mutable retreating: bool and 'a call =
(** Holds if [dst] is an ancestor in a depth-first traversal. *) } { callee: 'a
; typ: Typ.t (** Type of the callee. *)
(** A jump with arguments to a block. *) ; args: Exp.t list (** Stack of arguments, first-arg-last. *)
type jump = block control_transfer ; areturn: Var.t option (** Register to receive return value. *)
; return: jump (** Return destination. *)
; throw: jump option (** Handler destination. *)
; ignore_result: bool (** Drop return value when invoking return. *)
; mutable recursive: bool
(** Holds unless [callee] is definitely not recursive. *)
; loc: Loc.t }
(** Block terminators for function call/return or other control transfers. *) (** Block terminators for function call/return or other control transfers. *)
and term = private and term = private
@ -78,14 +64,8 @@ and term = private
[case] which is equal to [key], if any, otherwise invoke [els]. *) [case] which is equal to [key], if any, otherwise invoke [els]. *)
| Iswitch of {ptr: Exp.t; tbl: jump vector; loc: Loc.t} | Iswitch of {ptr: Exp.t; tbl: jump vector; loc: Loc.t}
(** Invoke the [jump] in [tbl] whose [dst] is equal to [ptr]. *) (** Invoke the [jump] in [tbl] whose [dst] is equal to [ptr]. *)
| Call of | Call of Exp.t call
{ call: Exp.t control_transfer (** A [global] for non-virtual call. *) (** Call function with arguments. A [global] for non-virtual call. *)
; typ: Typ.t (** Type of the callee. *)
; return: jump (** Return destination or trampoline. *)
; throw: jump option (** Handler destination or trampoline. *)
; ignore_result: bool (** Drop return value when invoking return. *)
; loc: Loc.t }
(** Call function [call.dst] with arguments [call.args]. *)
| Return of {exp: Exp.t option; loc: Loc.t} | Return of {exp: Exp.t option; loc: Loc.t}
(** Invoke [return] of the dynamically most recent [Call]. *) (** Invoke [return] of the dynamically most recent [Call]. *)
| Throw of {exc: Exp.t; loc: Loc.t} | Throw of {exc: Exp.t; loc: Loc.t}
@ -97,7 +77,6 @@ and term = private
(** A block is a destination of a jump with arguments, contains code. *) (** A block is a destination of a jump with arguments, contains code. *)
and block = private and block = private
{ lbl: label { lbl: label
; params: Var.t list (** Formal parameters, first-param-last stack *)
; cmnd: cmnd ; cmnd: cmnd
; term: term ; term: term
; mutable parent: func ; mutable parent: func
@ -111,11 +90,12 @@ 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 *)
; freturn: Var.t option
; fthrow: Var.t
; locals: Var.Set.t (** Local variables *) ; locals: Var.Set.t (** Local variables *)
; entry: block ; entry: block
; cfg: cfg ; cfg: cfg }
; freturn: Var.t option
; fthrow: Var.t }
type functions type functions
@ -151,8 +131,7 @@ module Jump : sig
type t = jump [@@deriving compare, equal, sexp_of] type t = jump [@@deriving compare, equal, sexp_of]
val pp : jump pp val pp : jump pp
val mk : string -> Exp.t list -> jump val mk : string -> jump
val push_arg : Exp.t -> jump -> jump
end end
module Term : sig module Term : sig
@ -175,6 +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
-> return:jump -> return:jump
-> throw:jump option -> throw:jump option
-> ignore_result:bool -> ignore_result:bool
@ -193,10 +173,7 @@ module Block : sig
include Comparator.S with type t := t include Comparator.S with type t := t
val pp : t pp val pp : t pp
val mk : lbl:label -> cmnd:cmnd -> term:term -> block
include Invariant.S with type t := t
val mk : lbl:label -> params:Var.t list -> cmnd:cmnd -> term:term -> block
end end
module Func : sig module Func : sig
@ -206,7 +183,13 @@ module Func : sig
include Invariant.S with type t := t include Invariant.S with type t := t
val mk : name:Global.t -> entry:block -> cfg:block vector -> func val mk :
name:Global.t
-> params:Var.t list
-> entry:block
-> cfg:block vector
-> func
val mk_undefined : name:Global.t -> params:Var.t list -> t val mk_undefined : name:Global.t -> params:Var.t list -> t
val find : functions -> Var.t -> func option val find : functions -> Var.t -> func option

6
sledge/src/report.ml
Unescape View File

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

28
sledge/src/symbheap/domain.ml
Unescape View File

@ -29,17 +29,21 @@ let exec_assume (entry, current) cnd =
| Some current -> Some (entry, current) | Some current -> Some (entry, current)
| None -> None | None -> None
let exec_kill (entry, current) reg =
(entry, State_domain.exec_kill current reg)
let exec_move (entry, current) formal actual =
(entry, State_domain.exec_move current formal actual)
let exec_inst (entry, current) inst = let exec_inst (entry, current) inst =
match State_domain.exec_inst current inst with match State_domain.exec_inst current inst with
| Ok current -> Ok (entry, current) | Ok current -> Ok (entry, current)
| Error e -> Error e | Error e -> Error e
let exec_return (entry, current) formal actual = let exec_intrinsic ~skip_throw (entry, current) areturn intrinsic actuals =
(entry, State_domain.exec_return current formal actual)
let exec_intrinsic ~skip_throw (entry, current) result intrinsic actuals =
match match
State_domain.exec_intrinsic ~skip_throw current result intrinsic actuals State_domain.exec_intrinsic ~skip_throw current areturn intrinsic
actuals
with with
| None -> None | None -> None
| Some (Ok current) -> Some (Ok (entry, current)) | Some (Ok current) -> Some (Ok (entry, current))
@ -49,11 +53,8 @@ type from_call =
{state_from_call: State_domain.from_call; caller_entry: State_domain.t} {state_from_call: State_domain.from_call; caller_entry: State_domain.t}
[@@deriving sexp_of] [@@deriving sexp_of]
let jump actuals formals ?temps (entry, current) = let call ~summaries actuals areturn formals locals globals_vec
let current, _ = State_domain.jump actuals formals ?temps current in (entry, current) =
(entry, current)
let call ~summaries actuals formals locals globals_vec (entry, current) =
let globals = let globals =
Var.Set.of_vector Var.Set.of_vector
(Vector.map globals_vec ~f:(fun (g : Global.t) -> g.var)) (Vector.map globals_vec ~f:(fun (g : Global.t) -> g.var))
@ -67,7 +68,8 @@ let call ~summaries actuals formals locals globals_vec (entry, current) =
State_domain.pp current] State_domain.pp current]
; ;
let caller_current, state_from_call = let caller_current, state_from_call =
State_domain.call ~summaries actuals formals locals globals current State_domain.call ~summaries actuals areturn formals locals globals
current
in in
((caller_current, caller_current), {state_from_call; caller_entry= entry})) ((caller_current, caller_current), {state_from_call; caller_entry= entry}))
|> |>
@ -80,10 +82,10 @@ let post locals {caller_entry} (_, current) =
|> |>
[%Trace.retn fun {pf} -> pf "@,%a" pp] [%Trace.retn fun {pf} -> pf "@,%a" pp]
let retn formals {caller_entry; state_from_call} (_, current) = let retn formals freturn {caller_entry; state_from_call} (_, current) =
[%Trace.call fun {pf} -> pf "@,%a" State_domain.pp current] [%Trace.call fun {pf} -> pf "@,%a" State_domain.pp current]
; ;
(caller_entry, State_domain.retn formals state_from_call current) (caller_entry, State_domain.retn formals freturn state_from_call current)
|> |>
[%Trace.retn fun {pf} -> pf "@,%a" pp] [%Trace.retn fun {pf} -> pf "@,%a" pp]

7
sledge/src/symbheap/domain.mli
Unescape View File

@ -15,8 +15,9 @@ val init : Global.t vector -> t
val join : t -> t -> t val join : t -> t -> t
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_move : t -> Var.t -> Exp.t -> t
val exec_inst : t -> Llair.inst -> (t, unit) result val exec_inst : t -> Llair.inst -> (t, unit) result
val exec_return : t -> Var.t -> Exp.t -> t
val exec_intrinsic : val exec_intrinsic :
skip_throw:bool skip_throw:bool
@ -37,11 +38,11 @@ val create_summary :
-> State_domain.function_summary * t -> State_domain.function_summary * t
val apply_summary : t -> State_domain.function_summary -> t option val apply_summary : t -> State_domain.function_summary -> t option
val jump : Exp.t list -> Var.t list -> ?temps:Var.Set.t -> t -> t
val call : val call :
summaries:bool summaries:bool
-> Exp.t list -> Exp.t list
-> Var.t option
-> Var.t list -> Var.t list
-> Var.Set.t -> Var.Set.t
-> Global.t vector -> Global.t vector
@ -49,7 +50,7 @@ val call :
-> t * from_call -> t * from_call
val post : Var.Set.t -> from_call -> t -> t val post : Var.Set.t -> from_call -> t -> t
val retn : Var.t list -> from_call -> t -> t val retn : Var.t list -> Var.t option -> from_call -> t -> t
val dnf : t -> t list val dnf : t -> t list
val resolve_callee : val resolve_callee :

15
sledge/src/symbheap/exec.ml
Unescape View File

@ -52,7 +52,6 @@ let assume pre cnd =
if Sh.is_false post then None else Some post if Sh.is_false post then None else Some post
let kill pre reg = Sh.exists (Set.add Var.Set.empty reg) pre let kill pre reg = Sh.exists (Set.add Var.Set.empty reg) pre
let return pre formal exp = Sh.and_ (Exp.eq (Exp.var formal) exp) pre
(* { emp } (* { emp }
* rs := es * rs := es
@ -670,10 +669,10 @@ let exec_spec pre {xs; foot; sub; ms; post} =
Format.fprintf fs "%a := " Var.Set.pp ms ) Format.fprintf fs "%a := " Var.Set.pp ms )
ms Sh.pp post ; ms Sh.pp post ;
assert ( assert (
let vs = Set.diff (Set.diff foot.Sh.us xs) pre.Sh.us in let vs = Set.diff (Set.diff foot.us xs) pre.us in
Set.is_empty vs || Trace.fail "unbound foot: {%a}" Var.Set.pp vs ) ; Set.is_empty vs || Trace.fail "unbound foot: {%a}" Var.Set.pp vs ) ;
assert ( assert (
let vs = Set.diff (Set.diff post.Sh.us xs) pre.Sh.us in let vs = Set.diff (Set.diff post.us xs) pre.us in
Set.is_empty vs || Trace.fail "unbound post: {%a}" Var.Set.pp vs )] Set.is_empty vs || Trace.fail "unbound post: {%a}" Var.Set.pp vs )]
; ;
let foot = Sh.extend_us xs foot in let foot = Sh.extend_us xs foot in
@ -698,6 +697,10 @@ let rec exec_specs pre = function
exec_specs pre specs >>| fun posts -> Sh.or_ post posts exec_specs pre specs >>| fun posts -> Sh.or_ post posts
| [] -> Ok (Sh.false_ pre.us) | [] -> Ok (Sh.false_ pre.us)
let move pre reg exp =
exec_spec pre (move_spec pre.us (Vector.of_array [|(reg, exp)|]))
|> function Ok post -> post | _ -> assert false
let inst : Sh.t -> Llair.inst -> (Sh.t, unit) result = let inst : Sh.t -> Llair.inst -> (Sh.t, unit) result =
fun pre inst -> fun pre inst ->
[%Trace.info [%Trace.info
@ -727,18 +730,18 @@ let intrinsic ~skip_throw :
-> Var.t -> Var.t
-> Exp.t list -> Exp.t list
-> (Sh.t, unit) result option = -> (Sh.t, unit) result option =
fun pre result 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)
result Var.pp intrinsic (List.pp ",@ " Exp.pp) (List.rev actuals) areturn Var.pp intrinsic (List.pp ",@ " Exp.pp) (List.rev actuals)
Sh.pp pre] ; Sh.pp pre] ;
let us = pre.us in let us = pre.us in
let name = let name =
let n = Var.name intrinsic in let n = Var.name intrinsic in
match String.index n '.' with None -> n | Some i -> String.prefix n i match String.index n '.' with None -> n | Some i -> String.prefix n i
in in
match (result, name, actuals) with match (areturn, name, actuals) with
(* (*
* cstdlib - memory management * cstdlib - memory management
*) *)

3
sledge/src/symbheap/exec.mli
Unescape View File

@ -8,7 +8,8 @@
(** Symbolic Execution *) (** Symbolic Execution *)
val assume : Sh.t -> Exp.t -> Sh.t option val assume : Sh.t -> Exp.t -> Sh.t option
val return : Sh.t -> Var.t -> Exp.t -> Sh.t val kill : Sh.t -> Var.t -> Sh.t
val move : Sh.t -> Var.t -> Exp.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 :

2
sledge/src/symbheap/solver.ml
Unescape View File

@ -61,7 +61,7 @@ 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 -> | Exp.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 (Exp.fv e) ~of_:xs then Exp.bool true else e
| e -> e | e -> e

58
sledge/src/symbheap/state_domain.ml
Unescape View File

@ -27,7 +27,8 @@ let init globals =
let join = Sh.or_ let join = Sh.or_
let is_false = Sh.is_false let is_false = Sh.is_false
let exec_assume = Exec.assume let exec_assume = Exec.assume
let exec_return = Exec.return let exec_kill = Exec.kill
let exec_move = Exec.move
let exec_inst = Exec.inst let exec_inst = Exec.inst
let exec_intrinsic = Exec.intrinsic let exec_intrinsic = Exec.intrinsic
let dnf = Sh.dnf let dnf = Sh.dnf
@ -66,46 +67,22 @@ let garbage_collect (q : t) ~wrt =
|> |>
[%Trace.retn fun {pf} -> pf "%a" pp] [%Trace.retn fun {pf} -> pf "%a" pp]
type from_call = {subst: Var.Subst.t; frame: Sh.t} type from_call = {areturn: Var.t option; subst: Var.Subst.t; frame: Sh.t}
[@@deriving compare, equal, sexp] [@@deriving compare, equal, sexp]
(** Express formula in terms of formals instead of actuals, and enter scope
of locals: rename formals to fresh vars in formula and actuals, add
equations between each formal and actual, and quantify the temps and
fresh vars. *)
let jump actuals formals ?temps q =
[%Trace.call fun {pf} ->
pf "@[<hv>actuals: (@[%a@])@ formals: (@[%a@])@ q: %a@]"
(List.pp ",@ " Exp.pp) (List.rev actuals) (List.pp ",@ " Var.pp)
(List.rev formals) Sh.pp q]
;
let q', freshen_locals = Sh.freshen q ~wrt:(Var.Set.of_list formals) in
let and_eq q formal actual =
let actual' = Exp.rename freshen_locals actual in
Sh.and_ (Exp.eq (Exp.var formal) actual') q
in
let and_eqs formals actuals q =
List.fold2_exn ~f:and_eq formals actuals ~init:q
in
( Option.fold ~f:(Fn.flip Sh.exists) temps
~init:(and_eqs formals actuals q')
, {subst= freshen_locals; frame= Sh.emp} )
|>
[%Trace.retn fun {pf} (q', {subst}) ->
pf "@[<hv>subst: %a@ q': %a@]" Var.Subst.pp subst Sh.pp q']
(** Express formula in terms of formals instead of actuals, and enter scope (** Express formula in terms of formals instead of actuals, and enter scope
of locals: rename formals to fresh vars in formula and actuals, add of locals: rename formals to fresh vars in formula and actuals, add
equations between each formal and actual, and quantify fresh vars. *) equations between each formal and actual, and quantify fresh vars. *)
let call ~summaries actuals formals locals globals q = let call ~summaries actuals areturn formals locals globals q =
[%Trace.call fun {pf} -> [%Trace.call fun {pf} ->
pf pf
"@[<hv>actuals: (@[%a@])@ formals: (@[%a@])@ locals: {@[%a@]}@ q: %a@]" "@[<hv>actuals: (@[%a@])@ formals: (@[%a@])@ locals: {@[%a@]}@ q: %a@]"
(List.pp ",@ " Exp.pp) (List.rev actuals) (List.pp ",@ " Var.pp) (List.pp ",@ " Exp.pp) (List.rev actuals) (List.pp ",@ " Var.pp)
(List.rev formals) Var.Set.pp locals pp q] (List.rev formals) Var.Set.pp locals pp q]
; ;
let wrt = Set.add_list formals locals in let q', freshen_locals =
let q', freshen_locals = Sh.freshen q ~wrt in Sh.freshen q ~wrt:(Set.add_list formals locals)
in
let and_eq q formal actual = let and_eq q formal actual =
let actual' = Exp.rename freshen_locals actual in let actual' = Exp.rename freshen_locals actual in
Sh.and_ (Exp.eq (Exp.var formal) actual') q Sh.and_ (Exp.eq (Exp.var formal) actual') q
@ -116,7 +93,7 @@ let call ~summaries actuals formals locals globals q =
let q'' = and_eqs formals actuals q' in let q'' = and_eqs formals actuals q' in
( if not summaries then ( if not summaries then
let q'' = Sh.extend_us locals q'' in let q'' = Sh.extend_us locals q'' in
(q'', {subst= freshen_locals; frame= Sh.emp}) (q'', {areturn; subst= freshen_locals; frame= Sh.emp})
else else
let formals_set = Var.Set.of_list formals in let formals_set = Var.Set.of_list formals in
(* Add the formals here to do garbage collection and then get rid of (* Add the formals here to do garbage collection and then get rid of
@ -134,7 +111,7 @@ let call ~summaries actuals formals locals globals q =
~message:"Solver couldn't infer frame of a garbage-collected pre" ~message:"Solver couldn't infer frame of a garbage-collected pre"
in in
let q'' = Sh.extend_us locals (and_eqs formals actuals foot) in let q'' = Sh.extend_us locals (and_eqs formals actuals foot) in
(q'', {subst= freshen_locals; frame}) ) (q'', {areturn; subst= freshen_locals; frame}) )
|> |>
[%Trace.retn fun {pf} (q', {subst; frame}) -> [%Trace.retn fun {pf} (q', {subst; frame}) ->
pf "@[<v>subst: %a@ frame: %a@ q': %a@]" Var.Subst.pp subst pp frame pp pf "@[<v>subst: %a@ frame: %a@ q': %a@]" Var.Subst.pp subst pp frame pp
@ -152,13 +129,19 @@ let post locals q =
(** Express in terms of actuals instead of formals: existentially quantify (** Express in terms of actuals instead of formals: existentially quantify
formals, and apply inverse of fresh variables for formals renaming to formals, and apply inverse of fresh variables for formals renaming to
restore the shadowed variables. *) restore the shadowed variables. *)
let retn formals {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 ", " Var.pp) formals Var.Subst.pp (Var.Subst.invert subst) pp
q pp frame] q pp frame]
; ;
let q = Sh.exists (Var.Set.of_list formals) q in let q =
match (areturn, freturn) with
| Some areturn, Some freturn -> exec_move q areturn (Exp.var freturn)
| Some areturn, None -> exec_kill q areturn
| _ -> q
in
let q = Sh.exists (Set.add_list formals (Var.Set.of_option freturn)) q in
let q = Sh.rename (Var.Subst.invert subst) q in let q = Sh.rename (Var.Subst.invert subst) q in
Sh.star frame q Sh.star frame q
|> |>
@ -175,13 +158,12 @@ let pp_function_summary fs {xs; foot; post} =
Format.fprintf fs "@[<v>xs: @[%a@]@ foot: %a@ post: %a @]" Var.Set.pp xs Format.fprintf fs "@[<v>xs: @[%a@]@ foot: %a@ post: %a @]" Var.Set.pp xs
pp foot pp post pp foot pp post
let create_summary ~locals ~formals ~entry ~current = 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" Var.Set.pp formals pp entry pp
current] post]
; ;
let foot = Sh.exists locals entry in let foot = Sh.exists locals entry in
let post = Sh.exists locals current 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 ->
@ -199,7 +181,7 @@ let create_summary ~locals ~formals ~entry ~current =
let xs_and_formals = Set.union xs formals in let xs_and_formals = Set.union xs formals in
let foot = Sh.exists (Set.diff foot.us xs_and_formals) foot in let foot = Sh.exists (Set.diff foot.us xs_and_formals) foot in
let post = Sh.exists (Set.diff post.us xs_and_formals) post in let post = Sh.exists (Set.diff post.us xs_and_formals) post in
let current = Sh.extend_us xs current in let current = Sh.extend_us xs post in
({xs; foot; post}, current) ({xs; foot; post}, current)
|> |>
[%Trace.retn fun {pf} (fs, _) -> pf "@,%a" pp_function_summary fs] [%Trace.retn fun {pf} (fs, _) -> pf "@,%a" pp_function_summary fs]

9
sledge/src/symbheap/state_domain.mli
Unescape View File

@ -14,8 +14,9 @@ val init : Global.t vector -> t
val join : t -> t -> t val join : t -> t -> t
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_move : t -> Var.t -> Exp.t -> t
val exec_inst : t -> Llair.inst -> (t, unit) result val exec_inst : t -> Llair.inst -> (t, unit) result
val exec_return : t -> Var.t -> Exp.t -> t
val exec_intrinsic : val exec_intrinsic :
skip_throw:bool skip_throw:bool
@ -27,12 +28,10 @@ val exec_intrinsic :
type from_call [@@deriving compare, equal, sexp] type from_call [@@deriving compare, equal, sexp]
val jump :
Exp.t list -> Var.t list -> ?temps:Var.Set.t -> t -> t * from_call
val call : val call :
summaries:bool summaries:bool
-> Exp.t list -> Exp.t list
-> Var.t option
-> Var.t list -> Var.t list
-> Var.Set.t -> Var.Set.t
-> Var.Set.t -> Var.Set.t
@ -54,7 +53,7 @@ val create_summary :
-> function_summary * t -> function_summary * t
val post : Var.Set.t -> t -> t val post : Var.Set.t -> t -> t
val retn : Var.t list -> from_call -> t -> t val retn : Var.t list -> Var.t option -> from_call -> t -> t
val dnf : t -> t list val dnf : t -> t list
val resolve_callee : val resolve_callee :

Write Preview
Loading…
Cancel
Save