@ -11,448 +11,456 @@
type exec_opts = { bound : int ; skip_throw : bool ; function_summaries : bool } type exec_opts = { bound : int ; skip_throw : bool ; function_summaries : bool }
module Stack : sig module Make ( Dom : Domain_sig . Dom ) = struct
type t
module Stack : sig
type as_inlined_location = t [ @@ deriving compare , sexp_of ]
type t
type as_inlined_location = t [ @@ deriving compare , sexp_of ]
val empty : t
val empty : t
val push_call :
Llair . func Llair . call -> bound : int -> Domain . from_call -> t -> t option
val push_call :
Llair . func Llair . call -> bound : int -> Dom . from_call -> t -> t option
val pop_return : t -> ( Domain . from_call * Llair . jump * t ) option
val pop_return : t -> ( Dom . from_call * Llair . jump * t ) option
val pop_throw :
t
val pop_throw :
-> init : ' a
t
-> unwind : ( Var . t list -> Var . Set . t -> Domain . from_call -> ' a -> ' a )
-> init : ' a
-> ( Domain . from_call * Llair . jump * t * ' a ) option
-> unwind : ( Var . t list -> Var . Set . t -> Dom . from_call -> ' a -> ' a )
end = struct -> ( Dom . from_call * Llair . jump * t * ' a ) option
type t =
end = struct
| Return of
type t =
{ recursive : bool (* * return from a possibly-recursive call *)
| Return of
; dst : Llair . Jump . t
{ recursive : bool (* * return from a possibly-recursive call *)
; params : Var . t list
; dst : Llair . Jump . t
; locals : Var . Set . t
; params : Var . t list
; from_call : Domain . from_call
; locals : Var . Set . t
; stk : t }
; from_call : Dom . from_call
| Throw of Llair . Jump . t * t
; stk : t }
| Empty
| Throw of Llair . Jump . t * t
[ @@ deriving sexp_of ]
| Empty
[ @@ deriving sexp_of ]
type as_inlined_location = t [ @@ deriving sexp_of ]
type as_inlined_location = t [ @@ deriving sexp_of ]
(* Treat a stack as a code location in a hypothetical expansion of the
program where all non - recursive functions have been completely inlined .
(* Treat a stack as a code location in a hypothetical expansion of the
In particular , this means to compare stacks as if all Return frames for
program where all non - recursive functions have been completely
recursive calls had been removed . Additionally , the from_call info in
inlined . In particular , this means to compare stacks as if all Return
Return frames is ignored . * )
frames for recursive calls had been removed . Additionally , the
let rec compare_as_inlined_location x y =
from_call info in Return frames is ignored . * )
if x = = y then 0
let rec compare_as_inlined_location x y =
else
if x = = y then 0
match ( x , y ) with
else
| Return { recursive = true ; stk = x } , y
match ( x , y ) with
| x , Return { recursive = true ; stk = y } ->
| Return { recursive = true ; stk = x } , y
compare_as_inlined_location x y
| x , Return { recursive = true ; stk = y } ->
| Return { dst = j ; stk = x } , Return { dst = k ; stk = y } -> (
compare_as_inlined_location x y
match Llair . Jump . compare j k with
| Return { dst = j ; stk = x } , Return { dst = k ; stk = y } -> (
| 0 -> compare_as_inlined_location x y
match Llair . Jump . compare j k with
| n -> n )
| 0 -> compare_as_inlined_location x y
| Return _ , _ -> - 1
| n -> n )
| _ , Return _ -> 1
| Return _ , _ -> - 1
| Throw ( j , x ) , Throw ( k , y ) -> (
| _ , Return _ -> 1
match Llair . Jump . compare j k with
| Throw ( j , x ) , Throw ( k , y ) -> (
| 0 -> compare_as_inlined_location x y
match Llair . Jump . compare j k with
| n -> n )
| 0 -> compare_as_inlined_location x y
| Throw _ , _ -> - 1
| n -> n )
| _ , Throw _ -> 1
| Throw _ , _ -> - 1
| Empty , Empty -> 0
| _ , Throw _ -> 1
| Empty , Empty -> 0
let rec print_abbrev fs = function
| Return { recursive = false ; stk = s } ->
let rec print_abbrev fs = function
print_abbrev fs s ;
| Return { recursive = false ; stk = s } ->
Format . pp_print_char fs 'R'
print_abbrev fs s ;
| Return { recursive = true ; stk = s } ->
Format . pp_print_char fs 'R'
print_abbrev fs s ;
| Return { recursive = true ; stk = s } ->
Format . pp_print_string fs " R↑ "
print_abbrev fs s ;
| Throw ( _ , s ) ->
Format . pp_print_string fs " R↑ "
print_abbrev fs s ;
| Throw ( _ , s ) ->
Format . pp_print_char fs 'T'
print_abbrev fs s ;
| Empty -> ()
Format . pp_print_char fs 'T'
| Empty -> ()
let invariant s =
Invariant . invariant [ % here ] s [ % sexp_of : t ]
let invariant s =
@@ fun () ->
Invariant . invariant [ % here ] s [ % sexp_of : t ]
match s with
@@ fun () ->
| Return _ | Throw ( _ , Return _ ) | Empty -> ()
match s with
| Throw _ -> fail " malformed stack: %a " print_abbrev s ()
| Return _ | Throw ( _ , Return _ ) | Empty -> ()
| Throw _ -> fail " malformed stack: %a " print_abbrev s ()
let empty = Empty | > check invariant
let empty = Empty | > check invariant
let push_return Llair . { callee = { params ; locals } ; return ; recursive }
from_call stk =
let push_return Llair . { callee = { params ; locals } ; return ; recursive }
Return { recursive ; dst = return ; params ; locals ; from_call ; stk }
from_call stk =
| > check invariant
Return { recursive ; dst = return ; params ; locals ; from_call ; stk }
| > check invariant
let push_throw jmp stk =
( match jmp with None -> stk | Some jmp -> Throw ( jmp , stk ) )
let push_throw jmp stk =
| > check invariant
( match jmp with None -> stk | Some jmp -> Throw ( jmp , stk ) )
| > check invariant
let push_call ( Llair . { return ; throw } as call ) ~ bound from_call stk =
[ % Trace . call fun { pf } -> pf " %a " print_abbrev stk ]
let push_call ( Llair . { return ; throw } as call ) ~ bound from_call stk =
;
[ % Trace . call fun { pf } -> pf " %a " print_abbrev stk ]
let rec count_f_in_stack acc f = function
;
| Return { stk = next_frame ; dst = dest_block } ->
let rec count_f_in_stack acc f = function
count_f_in_stack
| Return { stk = next_frame ; dst = dest_block } ->
( if Llair . Jump . equal dest_block f then acc + 1 else acc )
count_f_in_stack
f next_frame
( if Llair . Jump . equal dest_block f then acc + 1 else acc )
| _ -> acc
f next_frame
in
| _ -> acc
let n = count_f_in_stack 0 return stk in
in
( if n > bound then None
let n = count_f_in_stack 0 return stk in
else Some ( push_throw throw ( push_return call from_call stk ) ) )
( if n > bound then None
| >
else Some ( push_throw throw ( push_return call from_call stk ) ) )
[ % Trace . retn fun { pf } _ ->
| >
pf " %d of %a on stack " n Llair . Jump . pp return ]
[ % Trace . retn fun { pf } _ ->
pf " %d of %a on stack " n Llair . Jump . pp return ]
let rec pop_return = function
| Throw ( _ , stk ) -> pop_return stk
let rec pop_return = function
| Return { from_call ; dst ; stk } -> Some ( from_call , dst , stk )
| Throw ( _ , stk ) -> pop_return stk
| Empty -> None
| Return { from_call ; dst ; stk } -> Some ( from_call , dst , stk )
let pop_throw stk ~ init ~ unwind =
let rec pop_throw_ state = function
| Return { params ; locals ; from_call ; stk } ->
pop_throw_ ( unwind params locals from_call state ) stk
| Throw ( dst , Return { from_call ; stk } ) ->
Some ( from_call , dst , stk , state )
| Empty -> None
| Empty -> None
| Throw _ as stk -> violates invariant stk
in
pop_throw_ init stk
end
module Work : sig let pop_throw stk ~ init ~ unwind =
type t
let rec pop_throw_ state = function
| Return { params ; locals ; from_call ; stk } ->
val init : Domain . t -> Llair . block -> int -> t
pop_throw_ ( unwind params locals from_call state ) stk
| Throw ( dst , Return { from_call ; stk } ) ->
type x
Some ( from_call , dst , stk , state )
| Empty -> None
val skip : x
| Throw _ as stk -> violates invariant stk
val seq : x -> x -> x
in
pop_throw_ init stk
val add :
? prev : Llair . block
-> retreating : bool
-> Stack . t
-> Domain . t
-> Llair . block
-> x
val run : f : ( Stack . t -> Domain . t -> Llair . block -> x ) -> t -> unit
end = struct
module Edge = struct
module T = struct
type t =
{ dst : Llair . Block . t
; src : Llair . Block . t option
; stk : Stack . as_inlined_location }
[ @@ deriving compare , sexp_of ]
end
include T
include Comparator . Make ( T )
let pp fs { dst ; src } =
Format . fprintf fs " #%i %s <--%a " dst . sort_index dst . lbl
( Option . pp " %a " ( fun fs ( src : Llair . Block . t ) ->
Format . fprintf fs " #%i %s " src . sort_index src . lbl ) )
src
end
end
module Depths = struct
module Work : sig
type t = int Map . M ( Edge ) . t
type t
val init : Dom . t -> Llair . block -> int -> t
type x
val skip : x
val seq : x -> x -> x
val add :
? prev : Llair . block
-> retreating : bool
-> Stack . t
-> Dom . t
-> Llair . block
-> x
val run : f : ( Stack . t -> Dom . t -> Llair . block -> x ) -> t -> unit
end = struct
module Edge = struct
module T = struct
type t =
{ dst : Llair . Block . t
; src : Llair . Block . t option
; stk : Stack . as_inlined_location }
[ @@ deriving compare , sexp_of ]
end
include T
include Comparator . Make ( T )
let pp fs { dst ; src } =
Format . fprintf fs " #%i %s <--%a " dst . sort_index dst . lbl
( Option . pp " %a " ( fun fs ( src : Llair . Block . t ) ->
Format . fprintf fs " #%i %s " src . sort_index src . lbl ) )
src
end
let empty = Map . empty ( module Edge )
module Depths = struct
let find = Map . find
type t = int Map . M ( Edge ) . t
let set = Map . set
let join x y =
let empty = Map . empty ( module Edge )
Map . merge x y ~ f : ( fun ~ key : _ -> function
let find = Map . find
| ` Left d | ` Right d -> Some d
let set = Map . set
| ` Both ( d1 , d2 ) -> Some ( Int . max d1 d2 ) )
end
type priority = int * Edge . t [ @@ deriving compare ]
let join x y =
type priority_queue = priority Fheap . t
Map . merge x y ~ f : ( fun ~ key : _ -> function
type waiting_states = ( Domain . t * Depths . t ) list Map . M ( Llair . Block ) . t
| ` Left d | ` Right d -> Some d
type t = priority_queue * waiting_states * int
| ` Both ( d1 , d2 ) -> Some ( Int . max d1 d2 ) )
type x = Depths . t -> t -> t
end
let empty_waiting_states : waiting_states = Map . empty ( module Llair . Block )
type priority = int * Edge . t [ @@ deriving compare ]
let pp_priority fs ( n , e ) = Format . fprintf fs " %i: %a " n Edge . pp e
type priority_queue = priority Fheap . t
type waiting_states = ( Dom . t * Depths . t ) list Map . M ( Llair . Block ) . t
type t = priority_queue * waiting_states * int
type x = Depths . t -> t -> t
let empty_waiting_states : waiting_states =
Map . empty ( module Llair . Block )
let pp_priority fs ( n , e ) = Format . fprintf fs " %i: %a " n Edge . pp e
let pp fs pq =
Format . fprintf fs " @[%a@] "
( List . pp " ::@ " pp_priority )
( Sequence . to_list ( Fheap . to_sequence pq ) )
let skip _ w = w
let seq x y d w = y d ( x d w )
let add ? prev ~ retreating stk state curr depths ( ( pq , ws , bound ) as work )
=
let edge = { Edge . dst = curr ; src = prev ; stk } in
let depth = Option . value ( Depths . find depths edge ) ~ default : 0 in
let depth = if retreating then depth + 1 else depth in
if depth > bound then (
[ % Trace . info " prune: %i: %a " depth Edge . pp edge ] ;
work )
else
let pq = Fheap . add pq ( depth , edge ) in
[ % Trace . info " @[<6>enqueue %i: %a@ | %a@] " depth Edge . pp edge pp pq ] ;
let depths = Depths . set depths ~ key : edge ~ data : depth in
let ws = Map . add_multi ws ~ key : curr ~ data : ( state , depths ) in
( pq , ws , bound )
let init state curr bound =
add ~ retreating : false Stack . empty state curr Depths . empty
( Fheap . create ~ cmp : compare_priority , empty_waiting_states , bound )
let rec run ~ f ( pq0 , ws , bnd ) =
match Fheap . pop pq0 with
| Some ( ( _ , ( { Edge . dst ; stk } as edge ) ) , pq ) -> (
match Map . find_and_remove ws dst with
| Some ( state :: states , ws ) ->
let join ( qa , da ) ( q , d ) = ( Dom . join q qa , Depths . join d da ) in
let qs , depths = List . fold ~ f : join ~ init : state states in
run ~ f ( f stk qs dst depths ( pq , ws , bnd ) )
| _ ->
[ % Trace . info " done: %a " Edge . pp edge ] ;
run ~ f ( pq , ws , bnd ) )
| None -> [ % Trace . info " queue empty " ] ; ()
end
let pp fs pq =
let exec_jump stk state block Llair . { dst ; retreating } =
Format . fprintf fs " @[%a@] "
Work . add ~ prev : block ~ retreating stk state dst
( List . pp " ::@ " pp_priority )
( Sequence . to_list ( Fheap . to_sequence pq ) )
let skip _ w = w
let summary_table = Hashtbl . create ( module Var )
let seq x y d w = y d ( x d w )
let add ? prev ~ retreating stk state curr depths ( ( pq , ws , bound ) as work )
let exec_call opts stk state block call globals =
=
let Llair . { callee ; args ; areturn ; return ; recursive } = call in
let edge = { Edge . dst = curr ; src = prev ; stk } in
let Llair . { name ; params ; freturn ; locals ; entry } = callee in
let depth = Option . value ( Depths . find depths edge ) ~ default : 0 in
[ % Trace . call fun { pf } ->
let depth = if retreating then depth + 1 else depth in
pf " %a from %a " Var . pp name . var Var . pp return . dst . parent . name . var ]
if depth > bound then (
;
[ % Trace . info " prune: %i: %a " depth Edge . pp edge ] ;
let dnf_states =
work )
if opts . function_summaries then Dom . dnf state else [ state ]
else
in
let pq = Fheap . add pq ( depth , edge ) in
let domain_call =
[ % Trace . info " @[<6>enqueue %i: %a@ | %a@] " depth Edge . pp edge pp pq ] ;
Dom . call args areturn params ( Set . add_option freturn locals ) globals
let depths = Depths . set depths ~ key : edge ~ data : depth in
in
let ws = Map . add_multi ws ~ key : curr ~ data : ( state , depths ) in
List . fold ~ init : Work . skip dnf_states ~ f : ( fun acc state ->
( pq , ws , bound )
match
if not opts . function_summaries then None
let init state curr bound =
else
add ~ retreating : false Stack . empty state curr Depths . empty
let maybe_summary_post =
( Fheap . create ~ cmp : compare_priority , empty_waiting_states , bound )
let state = fst ( domain_call ~ summaries : false state ) in
Hashtbl . find summary_table name . var
let rec run ~ f ( pq0 , ws , bnd ) =
> > = List . find_map ~ f : ( Dom . apply_summary state )
match Fheap . pop pq0 with
in
| Some ( ( _ , ( { Edge . dst ; stk } as edge ) ) , pq ) -> (
[ % Trace . info
match Map . find_and_remove ws dst with
" Maybe summary post: %a " ( Option . pp " %a " Dom . pp )
| Some ( state :: states , ws ) ->
maybe_summary_post ] ;
let join ( qa , da ) ( q , d ) = ( Domain . join q qa , Depths . join d da ) in
maybe_summary_post
let qs , depths = List . fold ~ f : join ~ init : state states in
with
run ~ f ( f stk qs dst depths ( pq , ws , bnd ) )
| None ->
| _ ->
let state , from_call =
[ % Trace . info " done: %a " Edge . pp edge ] ;
domain_call ~ summaries : opts . function_summaries state
run ~ f ( pq , ws , bnd ) )
in
| None -> [ % Trace . info " queue empty " ] ; ()
Work . seq acc
end ( match
Stack . push_call call ~ bound : opts . bound from_call stk
with
| Some stk ->
Work . add stk ~ prev : block ~ retreating : recursive state entry
| None -> Work . skip )
| Some post -> Work . seq acc ( exec_jump stk post block return ) )
| >
[ % Trace . retn fun { pf } _ -> pf " " ]
let pp_st () =
[ % Trace . printf
" @[<v>%t@] " ( fun fs ->
Hashtbl . iteri summary_table ~ f : ( fun ~ key ~ data ->
Format . fprintf fs " @[<v>%a:@ @[%a@]@]@ " Var . pp key
( List . pp " @, " Dom . pp_summary )
data ) ) ]
let exec_return ~ opts stk pre_state ( block : Llair . block ) exp globals =
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
| Some ( from_call , retn_site , stk ) ->
let exit_state =
match ( freturn , exp ) with
| Some freturn , Some return_val ->
Dom . exec_move pre_state freturn return_val
| None , None -> pre_state
| _ -> violates Llair . Func . invariant block . parent
in
let post_state = Dom . post locals from_call exit_state in
let post_state =
if opts . function_summaries then (
let globals =
Var . Set . of_vector
( Vector . map globals ~ f : ( fun ( g : Global . t ) -> g . var ) )
in
let function_summary , post_state =
Dom . create_summary ~ locals post_state
~ formals : ( Set . union ( Var . Set . of_list params ) globals )
in
Hashtbl . add_multi summary_table ~ key : name . var
~ data : function_summary ;
pp_st () ;
post_state )
else post_state
in
let retn_state = Dom . retn params freturn from_call post_state in
exec_jump stk retn_state block retn_site
| None -> Work . skip )
| >
[ % Trace . retn fun { pf } _ -> pf " " ]
let exec_jump stk state block Llair . { dst ; retreating } = let exec_throw stk pre_state ( block : Llair . block ) exc =
Work . add ~ prev : block ~ retreating stk state dst
let func = block . parent in
[ % Trace . call fun { pf } -> pf " from %a " Var . pp func . name . var ]
let summary_table = Hashtbl . create ( module Var ) ;
let unwind params scope from_call state =
let exec_call opts stk state block call globals = Dom . retn params ( Some func . fthrow ) from_call
let Llair . { callee ; args ; areturn ; return ; recursive } = call in
( Dom . post scope from_call state )
let Llair . { name ; params ; freturn ; locals ; entry } = callee in
in
[ % Trace . call fun { pf } ->
( match Stack . pop_throw stk ~ unwind ~ init : pre_state with
pf " %a from %a " Var . pp name . var Var . pp return . dst . parent . name . var ]
| Some ( from_call , retn_site , stk , unwind_state ) ->
;
let fthrow = func . fthrow in
let dnf_states =
let exit_state = Dom . exec_move unwind_state fthrow exc in
if opts . function_summaries then Domain . dnf state else [ state ]
let post_state = Dom . post func . locals from_call exit_state in
in
let retn_state =
let domain_call =
Dom . retn func . params func . freturn from_call post_state
Domain . call args areturn params ( Set . add_option freturn locals ) globals
in
in
exec_jump stk retn_state block retn_site
List . fold ~ init : Work . skip dnf_states ~ f : ( fun acc state ->
| None -> Work . skip )
match
| >
if not opts . function_summaries then None
[ % Trace . retn fun { pf } _ -> pf " " ]
else
let maybe_summary_post =
let exec_skip_func :
let state = fst ( domain_call ~ summaries : false state ) in
Stack . t
Hashtbl . find summary_table name . var
-> Dom . t
> > = List . find_map ~ f : ( Domain . apply_summary state )
-> Llair . block
in
-> Var . t option
[ % Trace . info
-> Llair . jump
" Maybe summary post: %a "
-> Work . x =
( Option . pp " %a " Domain . pp )
fun stk state block areturn return ->
maybe_summary_post ] ;
Report . unknown_call block . term ;
maybe_summary_post
let state = Option . fold ~ f : Dom . exec_kill ~ init : state areturn in
with
exec_jump stk state block return
| None ->
let state , from_call =
let exec_term :
domain_call ~ summaries : opts . function_summaries state
exec_opts -> Llair . t -> Stack . t -> Dom . t -> Llair . block -> Work . x =
in
fun opts pgm stk state block ->
Work . seq acc
[ % Trace . info " exec %a " Llair . Term . pp block . term ] ;
( match Stack . push_call call ~ bound : opts . bound from_call stk with
match block . term with
| Some stk ->
| Switch { key ; tbl ; els } ->
Work . add stk ~ prev : block ~ retreating : recursive state entry
Vector . fold tbl
| None -> Work . skip )
~ f : ( fun x ( case , jump ) ->
| Some post -> Work . seq acc ( exec_jump stk post block return ) )
match Dom . exec_assume state ( Exp . eq key case ) with
| >
| Some state -> exec_jump stk state block jump | > Work . seq x
[ % Trace . retn fun { pf } _ -> pf " " ]
| None -> x )
~ init :
let pp_st () =
[ % Trace . printf
" @[<v>%t@] " ( fun fs ->
Hashtbl . iteri summary_table ~ f : ( fun ~ key ~ data ->
Format . fprintf fs " @[<v>%a:@ @[%a@]@]@ " Var . pp key
( List . pp " @, " State_domain . pp_function_summary )
data ) ) ]
let exec_return ~ opts stk pre_state ( block : Llair . block ) exp globals =
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
| Some ( from_call , retn_site , stk ) ->
let exit_state =
match ( freturn , exp ) with
| Some freturn , Some return_val ->
Domain . exec_move pre_state freturn return_val
| None , None -> pre_state
| _ -> violates Llair . Func . invariant block . parent
in
let post_state = Domain . post locals from_call exit_state in
let post_state =
if opts . function_summaries then (
let globals =
Var . Set . of_vector
( Vector . map globals ~ f : ( fun ( g : Global . t ) -> g . var ) )
in
let function_summary , post_state =
Domain . create_summary ~ locals post_state
~ formals : ( Set . union ( Var . Set . of_list params ) globals )
in
Hashtbl . add_multi summary_table ~ key : name . var
~ data : function_summary ;
pp_st () ;
post_state )
else post_state
in
let retn_state = Domain . retn params freturn from_call post_state in
exec_jump stk retn_state block retn_site
| None -> Work . skip )
| >
[ % Trace . retn fun { pf } _ -> pf " " ]
let exec_throw stk pre_state ( block : Llair . block ) exc =
let func = block . parent in
[ % Trace . call fun { pf } -> pf " from %a " Var . pp func . name . var ]
;
let unwind params scope from_call state =
Domain . retn params ( Some func . fthrow ) from_call
( Domain . post scope from_call state )
in
( match Stack . pop_throw stk ~ unwind ~ init : pre_state with
| Some ( from_call , retn_site , stk , unwind_state ) ->
let fthrow = func . fthrow in
let exit_state = Domain . exec_move unwind_state fthrow exc in
let post_state = Domain . post func . locals from_call exit_state in
let retn_state =
Domain . retn func . params func . freturn from_call post_state
in
exec_jump stk retn_state block retn_site
| None -> Work . skip )
| >
[ % Trace . retn fun { pf } _ -> pf " " ]
let exec_skip_func :
Stack . t
-> Domain . t
-> Llair . block
-> Var . t option
-> Llair . jump
-> Work . x =
fun stk state block areturn return ->
Report . unknown_call block . term ;
let state = Option . fold ~ f : Domain . exec_kill ~ init : state areturn in
exec_jump stk state block return
let exec_term :
exec_opts -> Llair . t -> Stack . t -> Domain . t -> Llair . block -> Work . x =
fun opts pgm stk state block ->
[ % Trace . info " exec %a " Llair . Term . pp block . term ] ;
match block . term with
| Switch { key ; tbl ; els } ->
Vector . fold tbl
~ f : ( fun x ( case , jump ) ->
match Domain . exec_assume state ( Exp . eq key case ) with
| Some state -> exec_jump stk state block jump | > Work . seq x
| None -> x )
~ init :
( match
Domain . exec_assume state
( Vector . fold tbl ~ init : ( Exp . bool true )
~ f : ( fun b ( case , _ ) -> Exp . and_ ( Exp . dq key case ) b ) )
with
| Some state -> exec_jump stk state block els
| None -> Work . skip )
| Iswitch { ptr ; tbl } ->
Vector . fold tbl ~ init : Work . skip ~ f : ( fun x ( jump : Llair . jump ) ->
match
Domain . exec_assume state
( Exp . eq ptr
( Exp . label
~ parent : ( Var . name jump . dst . parent . name . var )
~ name : jump . dst . lbl ) )
with
| Some state -> exec_jump stk state block jump | > Work . seq x
| None -> x )
| Call ( { callee ; args ; areturn ; return } as call ) -> (
match
let lookup name =
Option . to_list ( Llair . Func . find pgm . functions name )
in
Domain . resolve_callee lookup callee state
with
| [] -> exec_skip_func stk state block areturn return
| callees ->
List . fold callees ~ init : Work . skip ~ f : ( fun x callee ->
( match
( match
Domain . exec_intrinsic ~ skip_throw : opts . skip_throw state
Dom . exec_assume state
areturn callee . name . var args
( Vector . fold tbl ~ init : ( Exp . bool true )
~ f : ( fun b ( case , _ ) -> Exp . and_ ( Exp . dq key case ) b ) )
with
with
| Some ( Error () ) ->
| Some state -> exec_jump stk state block els
Report . invalid_access_term ( Domain . project state ) block . term ;
| None -> Work . skip )
Work . skip
| Iswitch { ptr ; tbl } ->
| Some ( Ok state ) when Domain . is_false state -> Work . skip
Vector . fold tbl ~ init : Work . skip ~ f : ( fun x ( jump : Llair . jump ) ->
| Some ( Ok state ) -> exec_jump stk state block return
match
| None when Llair . Func . is_undefined callee ->
Dom . exec_assume state
exec_skip_func stk state block areturn return
( Exp . eq ptr
| None ->
( Exp . label
exec_call opts stk state block { call with callee }
~ parent : ( Var . name jump . dst . parent . name . var )
pgm . globals )
~ name : jump . dst . lbl ) )
| > Work . seq x ) )
with
| Return { exp } -> exec_return ~ opts stk state block exp pgm . globals
| Some state -> exec_jump stk state block jump | > Work . seq x
| Throw { exc } ->
| None -> x )
if opts . skip_throw then Work . skip else exec_throw stk state block exc
| Call ( { callee ; args ; areturn ; return } as call ) -> (
| Unreachable -> Work . skip
match
let lookup name =
let exec_inst : Option . to_list ( Llair . Func . find pgm . functions name )
Domain . t -> Llair . inst -> ( Domain . t , Domain . t * Llair . inst ) result =
in
fun state inst ->
Dom . resolve_callee lookup callee state
Domain . exec_inst state inst
with
| > Result . map_error ~ f : ( fun () -> ( state , inst ) )
| [] -> exec_skip_func stk state block areturn return
| callees ->
let exec_block : List . fold callees ~ init : Work . skip ~ f : ( fun x callee ->
exec_opts -> Llair . t -> Stack . t -> Domain . t -> Llair . block -> Work . x =
( match
fun opts pgm stk state block ->
Dom . exec_intrinsic ~ skip_throw : opts . skip_throw state
[ % Trace . info " exec %a " Llair . Block . pp block ] ;
areturn callee . name . var args
match Vector . fold_result ~ f : exec_inst ~ init : state block . cmnd with
with
| Ok state -> exec_term opts pgm stk state block
| Some ( Error () ) ->
| Error ( state , inst ) ->
Report . invalid_access_term
Report . invalid_access_inst ( Domain . project state ) inst ;
( Dom . report_fmt_thunk state )
Work . skip
block . term ;
Work . skip
let harness : exec_opts -> Llair . t -> ( int -> Work . t ) option = | Some ( Ok state ) when Dom . is_false state -> Work . skip
fun opts pgm ->
| Some ( Ok state ) -> exec_jump stk state block return
let entry_points = Config . find_list " entry-points " in
| None when Llair . Func . is_undefined callee ->
List . find_map entry_points ~ f : ( fun name ->
exec_skip_func stk state block areturn return
Llair . Func . find pgm . functions ( Var . program name ) )
| None ->
| > function
exec_call opts stk state block { call with callee }
| Some { locals ; params = [] ; entry } ->
pgm . globals )
Some
| > Work . seq x ) )
( Work . init
| Return { exp } -> exec_return ~ opts stk state block exp pgm . globals
( fst
| Throw { exc } ->
( Domain . call ~ summaries : opts . function_summaries [] None []
if opts . skip_throw then Work . skip
locals pgm . globals ( Domain . init pgm . globals ) ) )
else exec_throw stk state block exc
entry )
| Unreachable -> Work . skip
| _ -> None
let exec_inst : Dom . t -> Llair . inst -> ( Dom . t , Dom . t * Llair . inst ) result
let exec_pgm : exec_opts -> Llair . t -> unit = =
fun opts pgm ->
fun state inst ->
[ % Trace . call fun { pf } -> pf " @]@,@[ " ]
Dom . exec_inst state inst
;
| > Result . map_error ~ f : ( fun () -> ( state , inst ) )
( match harness opts pgm with
| Some work -> Work . run ~ f : ( exec_block opts pgm ) ( work opts . bound )
let exec_block :
| None -> fail " no applicable harness " () )
exec_opts -> Llair . t -> Stack . t -> Dom . t -> Llair . block -> Work . x =
| >
fun opts pgm stk state block ->
[ % Trace . retn fun { pf } _ -> pf " " ]
[ % Trace . info " exec %a " Llair . Block . pp block ] ;
match Vector . fold_result ~ f : exec_inst ~ init : state block . cmnd with
| Ok state -> exec_term opts pgm stk state block
| Error ( state , inst ) ->
Report . invalid_access_inst ( Dom . report_fmt_thunk state ) inst ;
Work . skip
let harness : exec_opts -> Llair . t -> ( int -> Work . t ) option =
fun opts pgm ->
let entry_points = Config . find_list " entry-points " in
List . find_map entry_points ~ f : ( fun name ->
Llair . Func . find pgm . functions ( Var . program name ) )
| > function
| Some { locals ; params = [] ; entry } ->
Some
( Work . init
( fst
( Dom . call ~ summaries : opts . function_summaries [] None []
locals pgm . globals ( Dom . init pgm . globals ) ) )
entry )
| _ -> None
let exec_pgm : exec_opts -> Llair . t -> unit =
fun opts pgm ->
[ % Trace . call fun { pf } -> pf " @]@,@[ " ]
;
( match harness opts pgm with
| Some work -> Work . run ~ f : ( exec_block opts pgm ) ( work opts . bound )
| None -> fail " no applicable harness " () )
| >
[ % Trace . retn fun { pf } _ -> pf " " ]
end
Benno Stein
5 years ago
committed by
Facebook Github Bot