@ -6,32 +6,46 @@
* )
* )
open ! IStd
open ! IStd
module L = Logging
open PulseBasicInterface
open PulseBasicInterface
open PulseDomainInterface
open PulseDomainInterface
(* * {2 Building arithmetic constraints} *)
(* * {2 Building arithmetic constraints} *)
let and_eq_terms t1 t2 astate =
let phi = PathCondition . and_eq t1 t2 ( AbductiveDomain . get_path_condition astate ) in
AbductiveDomain . set_path_condition phi astate
let and_term t astate =
let phi = PathCondition . and_term t ( AbductiveDomain . get_path_condition astate ) in
AbductiveDomain . set_path_condition phi astate
let and_nonnegative trace v astate =
let and_nonnegative trace v astate =
AddressAttributes . add_one v ( BoItv Itv . ItvPure . nat ) astate
AddressAttributes . add_one v ( BoItv Itv . ItvPure . nat ) astate
| > AddressAttributes . add_one v ( CItv ( CItv . zero_inf , trace ) )
| > AddressAttributes . add_one v ( CItv ( CItv . zero_inf , trace ) )
| > and_term PathCondition . Term . ( le zero ( of_absval v ) )
let and_positive trace v astate =
let and_positive trace v astate =
AddressAttributes . add_one v ( BoItv Itv . ItvPure . pos ) astate
AddressAttributes . add_one v ( BoItv Itv . ItvPure . pos ) astate
| > AddressAttributes . add_one v ( CItv ( CItv . ge_to IntLit . one , trace ) )
| > AddressAttributes . add_one v ( CItv ( CItv . ge_to IntLit . one , trace ) )
| > and_term PathCondition . Term . ( lt zero ( of_absval v ) )
let and_eq_int trace v i astate =
let and_eq_int trace v i astate =
AddressAttributes . add_one v ( BoItv ( Itv . ItvPure . of_int_lit i ) ) astate
AddressAttributes . add_one v ( BoItv ( Itv . ItvPure . of_int_lit i ) ) astate
| > AddressAttributes . add_one v ( CItv ( CItv . equal_to i , trace ) )
| > AddressAttributes . add_one v ( CItv ( CItv . equal_to i , trace ) )
| > and_eq_terms ( PathCondition . Term . of_absval v ) ( PathCondition . Term . of_intlit i )
(* * {2 Operations} *)
(* * {2 Operations} *)
type operand = LiteralOperand of IntLit . t | AbstractValueOperand of AbstractValue . t
type operand = LiteralOperand of IntLit . t | AbstractValueOperand of AbstractValue . t
let eval_ arith _operand location binop_addr binop_hist bop op_lhs op_rhs astate =
let eval_ citv _operand location binop_addr binop_hist bop op_lhs op_rhs astate =
let arith _of_op op astate =
let citv _of_op op astate =
match op with
match op with
| LiteralOperand i ->
| LiteralOperand i ->
Some ( CItv . equal_to i )
Some ( CItv . equal_to i )
@ -39,7 +53,7 @@ let eval_arith_operand location binop_addr binop_hist bop op_lhs op_rhs astate =
AddressAttributes . get_citv v astate | > Option . map ~ f : fst
AddressAttributes . get_citv v astate | > Option . map ~ f : fst
in
in
match
match
Option . both ( arith_of_op op_lhs astate ) ( arith _of_op op_rhs astate )
Option . both ( citv_of_op op_lhs astate ) ( citv _of_op op_rhs astate )
| > Option . bind ~ f : ( fun ( addr_lhs , addr_rhs ) -> CItv . binop bop addr_lhs addr_rhs )
| > Option . bind ~ f : ( fun ( addr_lhs , addr_rhs ) -> CItv . binop bop addr_lhs addr_rhs )
with
with
| None ->
| None ->
@ -64,16 +78,30 @@ let eval_bo_itv_binop binop_addr bop op_lhs op_rhs astate =
AddressAttributes . add_one binop_addr ( BoItv bo_itv ) astate
AddressAttributes . add_one binop_addr ( BoItv bo_itv ) astate
let eval_path_condition_binop binop_addr binop op_lhs op_rhs astate =
let term_of_op = function
| LiteralOperand i ->
PathCondition . Term . of_intlit i
| AbstractValueOperand v ->
PathCondition . Term . of_absval v
in
and_eq_terms
( PathCondition . Term . of_absval binop_addr )
( PathCondition . Term . of_binop binop ( term_of_op op_lhs ) ( term_of_op op_rhs ) )
astate
let eval_binop location binop op_lhs op_rhs binop_hist astate =
let eval_binop location binop op_lhs op_rhs binop_hist astate =
let binop_addr = AbstractValue . mk_fresh () in
let binop_addr = AbstractValue . mk_fresh () in
let astate =
let astate =
eval_arith_operand location binop_addr binop_hist binop op_lhs op_rhs astate
eval_path_condition_binop binop_addr binop op_lhs op_rhs astate
| > eval_citv_operand location binop_addr binop_hist binop op_lhs op_rhs
| > eval_bo_itv_binop binop_addr binop op_lhs op_rhs
| > eval_bo_itv_binop binop_addr binop op_lhs op_rhs
in
in
( astate , ( binop_addr , binop_hist ) )
( astate , ( binop_addr , binop_hist ) )
let eval_unop_arith location unop_addr unop operand_addr unop_hist astate =
let eval_unop_ citv location unop_addr unop operand_addr unop_hist astate =
match
match
AddressAttributes . get_citv operand_addr astate
AddressAttributes . get_citv operand_addr astate
| > Option . bind ~ f : ( function a , _ -> CItv . unop unop a )
| > Option . bind ~ f : ( function a , _ -> CItv . unop unop a )
@ -93,10 +121,18 @@ let eval_unop_bo_itv unop_addr unop operand_addr astate =
AddressAttributes . add_one unop_addr ( BoItv itv ) astate
AddressAttributes . add_one unop_addr ( BoItv itv ) astate
let eval_path_condition_unop unop_addr unop addr astate =
and_eq_terms
( PathCondition . Term . of_absval unop_addr )
PathCondition . Term . ( of_unop unop ( of_absval addr ) )
astate
let eval_unop location unop addr unop_hist astate =
let eval_unop location unop addr unop_hist astate =
let unop_addr = AbstractValue . mk_fresh () in
let unop_addr = AbstractValue . mk_fresh () in
let astate =
let astate =
eval_unop_arith location unop_addr unop addr unop_hist astate
eval_path_condition_unop unop_addr unop addr astate
| > eval_unop_citv location unop_addr unop addr unop_hist
| > eval_unop_bo_itv unop_addr unop addr
| > eval_unop_bo_itv unop_addr unop addr
in
in
( astate , ( unop_addr , unop_hist ) )
( astate , ( unop_addr , unop_hist ) )
@ -126,9 +162,13 @@ let eval_operand location astate = function
( None
( None
, Some
, Some
( CItv . equal_to i , Trace . Immediate { location ; history = [ ValueHistory . Assignment location ] } )
( CItv . equal_to i , Trace . Immediate { location ; history = [ ValueHistory . Assignment location ] } )
, Itv . ItvPure . of_int_lit i )
, Itv . ItvPure . of_int_lit i
, PathCondition . Term . of_intlit i )
| AbstractValueOperand v ->
| AbstractValueOperand v ->
( Some v , AddressAttributes . get_citv v astate , AddressAttributes . get_bo_itv v astate )
( Some v
, AddressAttributes . get_citv v astate
, AddressAttributes . get_bo_itv v astate
, PathCondition . Term . of_absval v )
let record_abduced event location addr_opt orig_arith_hist_opt arith_opt astate =
let record_abduced event location addr_opt orig_arith_hist_opt arith_opt astate =
@ -151,38 +191,55 @@ let record_abduced event location addr_opt orig_arith_hist_opt arith_opt astate
let bind_satisfiable ~ satisfiable astate ~ f = if satisfiable then f astate else ( astate , false )
let bind_satisfiable ~ satisfiable astate ~ f = if satisfiable then f astate else ( astate , false )
let prune_binop ~ is_then_branch if_kind location ~ negated bop lhs_op rhs_op astate =
let prune_binop ~ is_then_branch if_kind location ~ negated bop lhs_op rhs_op astate =
let value_lhs_opt , arith_lhs_opt , bo_itv_lhs = eval_operand location astate lhs_op in
let value_lhs_opt , arith_lhs_opt , bo_itv_lhs , path_cond_lhs =
let value_rhs_opt , arith_rhs_opt , bo_itv_rhs = eval_operand location astate rhs_op in
eval_operand location astate lhs_op
match
in
CItv . abduce_binop_is_true ~ negated bop ( Option . map ~ f : fst arith_lhs_opt )
let value_rhs_opt , arith_rhs_opt , bo_itv_rhs , path_cond_rhs =
( Option . map ~ f : fst arith_rhs_opt )
eval_operand location astate rhs_op
with
in
| Unsatisfiable ->
let astate , path_condition =
( astate , false )
let path_condition =
| Satisfiable ( abduced_lhs , abduced_rhs ) ->
let t_positive = PathCondition . Term . of_binop bop path_cond_lhs path_cond_rhs in
let event = ValueHistory . Conditional { is_then_branch ; if_kind ; location } in
let t = if negated then PathCondition . Term . not_ t_positive else t_positive in
let astate =
AbductiveDomain . get_path_condition astate | > PathCondition . and_term t
record_abduced event location value_lhs_opt arith_lhs_opt abduced_lhs astate
in
| > record_abduced event location value_rhs_opt arith_rhs_opt abduced_rhs
let astate = AbductiveDomain . set_path_condition path_condition astate in
in
( astate , path_condition )
let satisfiable =
in
match Itv . ItvPure . arith_binop bop bo_itv_lhs bo_itv_rhs | > Itv . ItvPure . to_boolean with
if PathCondition . is_unsat path_condition then (
| False ->
L . d_printfln " Contradiction detected in path condition " ;
negated
( astate , false ) )
| True ->
else
not negated
match
| Top ->
CItv . abduce_binop_is_true ~ negated bop ( Option . map ~ f : fst arith_lhs_opt )
true
( Option . map ~ f : fst arith_rhs_opt )
| Bottom ->
with
false
| Unsatisfiable ->
in
( astate , false )
let astate , satisfiable =
| Satisfiable ( abduced_lhs , abduced_rhs ) ->
bind_satisfiable ~ satisfiable astate ~ f : ( fun astate ->
let event = ValueHistory . Conditional { is_then_branch ; if_kind ; location } in
prune_with_bop ~ negated value_lhs_opt bo_itv_lhs bop bo_itv_rhs astate )
let astate =
in
record_abduced event location value_lhs_opt arith_lhs_opt abduced_lhs astate
Option . value_map ( Binop . symmetric bop ) ~ default : ( astate , satisfiable ) ~ f : ( fun bop' ->
| > record_abduced event location value_rhs_opt arith_rhs_opt abduced_rhs
in
let satisfiable =
match Itv . ItvPure . arith_binop bop bo_itv_lhs bo_itv_rhs | > Itv . ItvPure . to_boolean with
| False ->
negated
| True ->
not negated
| Top ->
true
| Bottom ->
false
in
let astate , satisfiable =
bind_satisfiable ~ satisfiable astate ~ f : ( fun astate ->
bind_satisfiable ~ satisfiable astate ~ f : ( fun astate ->
prune_with_bop ~ negated value_rhs_opt bo_itv_rhs bop' bo_itv_lhs astate ) )
prune_with_bop ~ negated value_lhs_opt bo_itv_lhs bop bo_itv_rhs astate )
in
Option . value_map ( Binop . symmetric bop ) ~ default : ( astate , satisfiable ) ~ f : ( fun bop' ->
bind_satisfiable ~ satisfiable astate ~ f : ( fun astate ->
prune_with_bop ~ negated value_rhs_opt bo_itv_rhs bop' bo_itv_lhs astate ) )
(* * {2 Queries} *)
(* * {2 Queries} *)
@ -190,4 +247,6 @@ let prune_binop ~is_then_branch if_kind location ~negated bop lhs_op rhs_op asta
let is_known_zero astate v =
let is_known_zero astate v =
( AddressAttributes . get_citv v astate
( AddressAttributes . get_citv v astate
| > function Some ( arith , _ ) -> CItv . is_equal_to_zero arith | None -> false )
| > function Some ( arith , _ ) -> CItv . is_equal_to_zero arith | None -> false )
| | ( let phi = AbductiveDomain . get_path_condition astate in
PathCondition . is_known_zero ( PathCondition . Term . of_absval v ) phi )
| | Itv . ItvPure . is_zero ( AddressAttributes . get_bo_itv v astate )
| | Itv . ItvPure . is_zero ( AddressAttributes . get_bo_itv v astate )